(SPECIAL OBLIST)
(SPECIAL DATUM CEXPRS)


(DEFPROP CNNVERFNS
 (CNNVERFNS (SPECIAL CSYSFNS DATUM CEXPRS OBLIST)
	    OBMAP
	    CDUMP
	    CSYSFNS
	    BOUNDP
	    COMMENT
	    NEWFNS
	    =
	    >
	    <
	    +
	    TYIPEEK
	    MAKREADTABLE
	    GRINPROPS
	    $$$SETQ
	    PI-OFF
	    PI-ON
	    SSTATUS
	    DELQ
	    DELETE
	    (DECLARE (SPECIAL OBARRAY READTABLE ERRLIST BASE IBASE))
	    (DECLARE (SPECIAL *TOP
			      UARGS
			      BODY
			      EARGS
			      CHALOBV
			      BVARS
			      ALINK
			      CLINK
			      EXP
			      FRAME*
			      FREEVARS
			      FRAMEVARS
			      LEVNUM
			      PC
			      RUNF
			      TEM
			      TEM1
			      TYPE
			      VAL
			      VARS
			      CINTERRUPT
			      SERRLI
			      ALLOW
			      READY
			      GLOBALS
			      *
			      **
			      ←)
		     (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: /@ /,)
		     (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN TRYASSIGN VALUE))
	    (PROGN (SETQ RUNF NIL)
		   (SETQ SERRLI NIL)
		   (SETQ ** (QUOTE **))
		   (SETQ GLOBALS (QUOTE ((NIL NIL) (T T))))
		   (SETQ *TOP (QUOTE *TOP)))
	    (COMMENT THE FRAME FORMAT IS AS FOLLOWS ((IVARS . PC) (BVARS . ALINK) EXP . CLINK))
	    (PROGN (SETQ FREEVARS (QUOTE (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW)))
		   (SETQ FRAMEVARS (QUOTE (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))))
	    BVARS
	    ALINK
	    EXP
	    CLINK
	    BODY
	    (COMMENT THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER)
	    RUN
	    RUN1
	    CAP
	    HANDLE
	    START
	    STOP
	    *STOP
	    U-LOSE
	    CERR
	    EAR
	    TOP
	    CINTERRUPT
	    ALLOW
	    (COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)
	    (DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))
	    DISPATCH
	    SAVEUP
	    SAVEV
	    (COMMENT FUNCTION CALLS RETURN VIA "POPJ")
	    POPJ
	    RESTORE
	    REST1
	    (DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))
	    BIND1
	    CLOSE
	    (COMMENT MOBY BINDER -- NORMAL FUNCTION LISTS)
	    ARGB
	    ARGB1
	    ARGQ
	    (COMMENT BIND UP "OPTIONAL"S AND "REST"S)
	    OPTMATCH
	    OPTMATCH1
	    RESTMATCH
	    EVREST
	    EVREST1
	    (COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)
	    FINVAR
	    FINVAR1
	    FINVAR2
	    FINVAR3
	    (COMMENT BINDS "AUX" VARIABLES)
	    AUXB
	    AUXB1
	    AUXB2
	    CPROG
	    PROG
	    PROGBIND
	    PROGB1
	    (COMMENT BASIC PROG ITERATION LOOP)
	    LINE
	    LINE1
	    (COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)
	    EVARGS
	    ARGS1
	    (COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)
	    CCOND
	    CONDLP
	    COND1
	    COND
	    IAND
	    IAND1
	    AND
	    IOR
	    IOR1
	    OR
	    (COMMENT USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS)
	    CGO
	    GO1
	    GO
	    CEXIT
	    EXIT1
	    EXIT2
	    EXIT
	    CRETURN
	    RETURN1
	    RETURN
	    CDISMISS
	    DISMISS
	    CONTINUE
	    CONT1
	    CONT2
	    (COMMENT RELATIVE EVALUATORS)
	    ICEVAL
	    CEVAL1
	    CEVAL2
	    CEVAL
	    ICALL
	    CALL1
	    CALL
	    INVOKE
	    TRY1
	    TRY2
	    TEXT
	    FR
	    (COMMENT IDENTIFIER MANIPULATORS)
	    VFRAME
	    VLOC
	    RVALUE
	    (DECLARE (SPECIAL ID))
	    IVAL
	    (DECLARE (UNSPECIAL ID))
	    ICSETQ
	    CSETQ0
	    CSETQ1
	    CSETQ
	    CSET
	    UNASSIGN
	    (COMMENT FRAME CONSTRUCTORS)
	    CHAUX
	    TAG
	    ACTBLOCK
	    ACCESS
	    CONTROL
	    CLOSURE
	    FRAME
	    (COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)
	    SETACCESS
	    SETCONTROL
	    (COMMENT DEBUGGING AIDS)
	    EXPRESSION
	    BACKTRACE
	    LISTENB
	    LISTEN
	    CONDB
	    PROGB
	    CEVALB
	    UPDATEB
	    UPDATE
	    SETB
	    SET
	    PROGBINDB
	    (COMMENT USER INTERFACE)
	    CDEFUN
	    GENLEV
	    /:
	    /@
	    /!
	    /,
	    CPRIN1
	    CPRINT
	    CP-MACR
	    CP-QUOTE
	    QUOTE
	    CP-*TAG
	    *TAG
	    *CLOSURE
	    CP-*FRAME
	    *FRAME
	    *AU-REVOIR
	    CP-MATCH
	    /!'
	    /!@
	    CP-!"
	    COLMAC
	    COMMAC
	    ATMAC
	    EXMAC
	    NXTCHR
	    SEPARATOR
	    (DECLARE (SPECIAL CFRAMES
			      CNUM
			      CONTEXT
			      DATUM
			      CMARKERS
			      TYPE
			      PATTERN
			      GLOBAL
			      INCCON
			      NUMACT
			      NUMCON
			      *CNUM
			      *IF-ADDEDS
			      *IF-NEEDEDS
			      *IF-REMOVEDS
			      *INDEXTHRESHOLD
			      *ITEMS
			      NEW)
		     (*FEXPR /!" CDEFUN CERR CSETQ /: /, GCCON IF-ADDED IF-NEEDED IF-REMOVED)
		     (*LEXPR BIND
			     ABSENT
			     ADD
			     CEVAL
			     CFRAME
			     CSET
			     VLOC
			     DGET
			     DGET+
			     DPUT
			     DPUT+
			     DREM
			     DREM+
			     FETCH
			     FETCHI
			     FETCHM
			     INSERT
			     KILL
			     MATCH
			     NOTE
			     OBJECT
			     POP-CONTEXT
			     PRESENT
			     DATA-INIT
			     PUSH-CONTEXT
			     REAL
			     REALIZE
			     REMOVE
			     RVALUE
			     UNREAL
			     UNREALIZE)
		     (*EXPR ARGS DATUM CMARKERS PATTERN)
		     (**ARRAY FRAMES RFRAMES))
	    (SETQ *INDEXTHRESHOLD 12)
	    OBJECT
	    TMA
	    TFA
	    (DECLARE (UNSPECIAL CMARKERS TYPE))
	    MAKE-METHOD
	    (DECLARE (SPECIAL CMARKERS TYPE))
	    IF-NEEDED
	    IF-ADDED
	    IF-REMOVED
	    DATA-INIT
	    (DECLARE (UNSPECIAL PATTERN))
	    FETCH
	    FETCHI
	    FETCHM
	    FETCHI1
	    FETCHM1
	    (DECLARE (SPECIAL PATTERN))
	    REAL
	    UNREAL
	    PRESENT
	    ABSENT
	    (DECLARE (UNSPECIAL PATTERN))
	    SEARCH
	    (DECLARE (SPECIAL PATTERN))
	    REALITY
	    REALITY1
	    DATUM
	    ADD
	    CREMOVE
	    REMOVE
	    INSERT
	    KILL
	    ACTUALIZE
	    UNACTUALIZE
	    (DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))
	    REALIZE
	    UNREALIZE
	    (DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))
	    CALLDEMONS
	    RUNDAEMONS
	    NXTMET
	    REVEAL
	    HIDE
	    ADDCFRAME
	    FINDCFRAME
	    CANCEL
	    MERGEN
	    MERGE
	    DPUTCF
	    DGETCF
	    DREMCF
	    DPUT
	    DGET
	    DREM
	    DPUT+
	    DGET+
	    DREM+
	    DPUT1
	    DGET1
	    DREM1
	    MENTIONERS
	    (DECLARE (UNSPECIAL DATUM))
	    C-MARKER
	    (DECLARE (SPECIAL DATUM))
	    MFINTERSECT
	    (DECLARE (UNSPECIAL CMARKERS))
	    INVISIBLE
	    (DECLARE (UNSPECIAL CFRAMES))
	    GETCONTEXT
	    (DECLARE (UNSPECIAL PATTERN))
	    ISEARCH
	    ISEARCH1
	    ASEARCH
	    ASSQ1
	    (DECLARE (SPECIAL THING PFORM INDEX))
	    INDEX
	    (DECLARE (UNSPECIAL PFORM INDEX))
	    UNINDEX
	    (DECLARE (UNSPECIAL THING))
	    INDEX1
	    UNINDEX1
	    (DECLARE (SPECIAL PATTERN))
	    ANALYZE
	    (DECLARE (UNSPECIAL PATTERN))
	    CMARKERS
	    PATTERN
	    DELTHING
	    DELITEM
	    MEMCAR
	    FIRSTCAR<
	    ITEM
	    DATUMIZE
	    ATOMIZE
	    PUSH-CONTEXT
	    POP-CONTEXT
	    (DECLARE (UNSPECIAL CFRAMES))
	    NEW-CONTEXT
	    (DECLARE (SPECIAL CFRAMES))
	    SPLICE
	    (DECLARE (SPECIAL EXPR))
	    IN-CONTEXT
	    (DECLARE (UNSPECIAL EXPR))
	    PATH
	    (DECLARE (SPECIAL PATTERN))
	    FINALIZE
	    (DECLARE (UNSPECIAL PATTERN))
	    CFRAME
	    ORDERED
	    NEWCNUM
	    CNUMSINUSE
	    *GCCON
	    GCCON
	    (DECLARE (SPECIAL PATTERN))
	    FLUSH
	    (DECLARE (UNSPECIAL PATTERN))
	    REMCFRAME
	    /!"
	    /!"1
	    KTH
	    (DECLARE (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
		     (*FEXPR CERR INSTANCE PROPOSE /,)
		     (*LEXPR CSET VFRAME ACCESS CONTROL))
	    ALINK
	    CLINK
	    TRY-NEXT
	    NEXT
	    SETUP
	    GENGO
	    METGO
	    REGO
	    TBLOCK
	    UNBLOCK
	    NOTE
	    ADIEU
	    AU-REVOIR
	    ENTER
	    PROPOSE
	    INSTANCE
	    CPY
	    GET-POSSIBILITIES
	    SET-POSSIBILITIES
	    GENERATE
	    (DECLARE (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND VALV)
		     (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
		     (*FEXPR CERR))
	    MATCH
	    (DECLARE (UNSPECIAL MALIST1 MALIST2))
	    MATCH1
	    (DECLARE (UNSPECIAL MALISTV2))
	    COMMA
	    (DECLARE (UNSPECIAL MALISTV1))
	    MATCH2
	    /!?
	    /!>
	    TRYASSIGN
	    /!<
	    /!;
	    CHECKVAL
	    (DECLARE (UNSPECIAL VALV))
	    FINDVARS
	    HASMUSTASSIGNS
	    HASVARS
	    VARSUBST
	    ACTOR
	    ACTORSUBST
	    GETSPEC
	    MBIND
	    MBINDV
	    (DECLARE (UNSPECIAL NOBIND))
	    MBINDR
	    /!/,
	    /!/,1
	    SATISFY
	    (DECLARE (UNSPECIAL MALIST))
	    MSET
	    ASSIGNED?
	    /;
	    CNVINT)
VALUE)

(SPECIAL CSYSFNS)

(DEFPROP OBMAP
 (LAMBDA (FN) (MAPC (FUNCTION (LAMBDA (X) (MAPC (FUNCTION (LAMBDA (Y) (APPLY# FN (NCONS Y)))) X))) OBLIST))
EXPR)

(DEFPROP CDUMP
 (LAMBDA(X)
  (PROG	(DATUM CEXPRS)
	(COND ((NULL (CDR X)) (SETQ X (LIST (CAR X) (QUOTE CEXPR) (QUOTE DATUM)))))
	(COND
	 ((MEMQ (QUOTE CEXPR) X)
	  (OBMAP
	   (QUOTE
	    (LAMBDA(X)
	     (COND ((AND (GET X (QUOTE CEXPR)) (NOT (MEMQ X CSYSFNS))) (SETQ CEXPRS (CONS X CEXPRS)))))))))
	(COND
	 ((MEMQ (QUOTE DATUM) X)
	  (OBMAP (QUOTE (LAMBDA (X) (COND ((GET X (QUOTE DATUM)) (SETQ DATUM (CONS X DATUM)))))))))
	(EVAL
	 (CONS (QUOTE DSKOUT)
	       (LIST (CAR X)
		     (QUOTE CEXPRS)
		     (QUOTE DATUM)
		     (QUOTE (PRINT (QUOTE (DATA))))
		     (QUOTE (MAPC (FUNCTION (LAMBDA (Y) (PRINT Y))) DATUM))
		     (QUOTE (PRINT NIL)))))))
FEXPR)

(DEFPROP CSYSFNS
 (CSYSFNS UNREALIZE RUNDAEMONS TRY-NEXT TBLOCK GENERATE REALIZE ADIEU AU-REVOIR IN-CONTEXT ADD REMOVE LISTEN)
VALUE)

(DEFPROP BOUNDP
 (LAMBDA(X)
  (PROG (Y) (SETQ Y (GET X (QUOTE VALUE))) (COND ((NOT (OR (NULL Y) (EQ (CDR Y) (UNBOUND)))) (RETURN Y)))))
EXPR)

(DEFPROP COMMENT
 (LAMBDA (L) (QUOTE (COMMENT --)))
FEXPR)

(DEFPROP NEWFNS
 (NEWFNS NIL)
VALUE)

(DEFPROP =
 (LAMBDA (X Y) (EQ X Y))
EXPR)

(DEFPROP >
 (LAMBDA (X Y) (*GREAT X Y))
EXPR)

(DEFPROP <
 (LAMBDA (X Y) (*LESS X Y))
EXPR)

(DEFPROP +
 (LAMBDA (X Y) (*PLUS X Y))
EXPR)

(DEFPROP TYIPEEK
 (LAMBDA NIL (UNTYI (TYI)))
EXPR)

(DEFPROP MAKREADTABLE
 (LAMBDA (X) (NCONC NEWFNS (NCONS (CONS (QUOTE MAKREADTABLE) X))))
EXPR)

(DEFPROP GRINPROPS
 (NIL EXPR FEXPR MACRO VALUE SPECIAL CEXPR CINT CPRINT BACKTRACE DATUM)
VALUE)

(DEFPROP $$$SETQ
 (LAMBDA(X)
  (COND	((NULL (CDDDR X)) (RPLACA X (QUOTE SETQ)))
	(T
	 (PROG (Z)
	       (RPLACA X (QUOTE PROGN))
	       (SETQ Z X)
	  LOOP (SETQ Z (CDR Z))
	       (COND ((NULL Z) (RETURN X)))
	       (RPLACA Z (LIST (QUOTE SETQ) (CAR Z) (CADR Z)))
	       (RPLACD Z (CDDR Z))
	       (GO LOOP)))))
MACRO)

(DEFPROP PI-OFF
 (LAMBDA (X) (NILL X))
FEXPR)

(DEFPROP PI-ON
 (LAMBDA (X) (NILL X))
FEXPR)

(DEFPROP SSTATUS
 (LAMBDA (X) (NILL X))
FEXPR)

(DEFPROP DELQ
 (LAMBDA(WHAT FROM TIMES)
  (COND	((NULL FROM) FROM)
	(TIMES (COND ((EQ WHAT (CAR FROM)) (CDR FROM)) (T (RPLACD FROM (DELQ WHAT (CDR FROM) TIMES)))))
	((EQ WHAT (CAR FROM)) (DELQ WHAT (CDR FROM) TIMES))
	(T (DREMOVE WHAT FROM))))
EXPR)

(DEFPROP DELETE
 (LAMBDA(WHAT FROM TIMES)
  (COND	((NULL FROM) FROM)
	(TIMES (COND ((EQUAL WHAT (CAR FROM)) (CDR FROM)) (T (RPLACD FROM (DELETE WHAT (CDR FROM) TIMES)))))
	(T
	 (COND ((EQUAL WHAT (CAR FROM)) (DELQ WHAT (CDR FROM) TIMES))
	       (T (RPLACD FROM (DELETE WHAT (CDR FROM) TIMES)))))))
EXPR)

(DECLARE (SPECIAL OBARRAY READTABLE ERRLIST BASE IBASE))

(DECLARE (SPECIAL *TOP
		  UARGS
		  BODY
		  EARGS
		  CHALOBV
		  BVARS
		  ALINK
		  CLINK
		  EXP
		  FRAME*
		  FREEVARS
		  FRAMEVARS
		  LEVNUM
		  PC
		  RUNF
		  TEM
		  TEM1
		  TYPE
		  VAL
		  VARS
		  CINTERRUPT
		  SERRLI
		  ALLOW
		  READY
		  GLOBALS
		  *
		  **
		  ←)
	 (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: /@ /,)
	 (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN TRYASSIGN VALUE))

(PROGN (SETQ RUNF NIL)
       (SETQ SERRLI NIL)
       (SETQ ** (QUOTE **))
       (SETQ GLOBALS (QUOTE ((NIL NIL) (T T))))
       (SETQ *TOP (QUOTE *TOP)))

(COMMENT THE FRAME FORMAT IS AS FOLLOWS ((IVARS . PC) (BVARS . ALINK) EXP . CLINK))

(PROGN (SETQ FREEVARS (QUOTE (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW)))
       (SETQ FRAMEVARS (QUOTE (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))))

(DEFPROP BVARS
 (LAMBDA (L) (LIST (QUOTE CAADR) (CADR L)))
MACRO)

(DEFPROP ALINK
 (LAMBDA (L) (LIST (QUOTE CDADR) (CADR L)))
MACRO)

(DEFPROP EXP
 (LAMBDA (L) (LIST (QUOTE CADDR) (CADR L)))
MACRO)

(DEFPROP CLINK
 (LAMBDA (L) (LIST (QUOTE CDDDR) (CADR L)))
MACRO)

(DEFPROP BODY
 (LAMBDA (L) (QUOTE (CADR (ASSOC (QUOTE *BODY) BVARS))))
MACRO)

(COMMENT THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER)

(DEFPROP RUN
 (LAMBDA L (SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL))) (RUN1))
EXPR)

(DEFPROP RUN1
 (LAMBDA NIL
  (COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
  ((LAMBDA(BASE IBASE READTABLE)
    (PROG (RUNF ERET)
	  (PROGN (SETQ RUNF T) (SETQ ERRLIST SERRLI))
     ERRL (SETQ	ERET
		(ERRSET
		 (PROG NIL
		  LOOP (COND ((AND# CINTERRUPT ALLOW) (SETQ PC (HANDLE))) ((SETQ PC (CAP PC))))
		       (GO LOOP))))
	  (COND ((EQ ERET (QUOTE %%%STOP)) (RETURN VAL)) ((NULL ERET) (SETQ TEM1 (QUOTE (GO (CEVAL EAR))))))
	  (GO ERRL)))
   12
   12
   (GET (QUOTE CONNIVREAD) (QUOTE ARRAY))))
EXPR)

(DEFPROP CAP
 (LAMBDA (P) (APPLY# P NIL))
EXPR)

(DEFPROP HANDLE
 (LAMBDA NIL
  (PROG2 0
	 (DISPATCH (PROG2 0 (CAR CINTERRUPT) (SETQ CINTERRUPT (CDR CINTERRUPT))) PC FREEVARS (QUOTE *TOP))
	 (SETQ ALLOW NIL)))
EXPR)

(DEFPROP START
 (LAMBDA NIL
  (COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
  (MAPC (QUOTE (LAMBDA (V) (SET V NIL))) (APPEND FRAMEVARS FREEVARS))
  (PROGN (SETQ PC (QUOTE ICEVAL))
	 (SETQ EXP (QUOTE (CEVAL (QUOTE (LISTEN (QUOTE TOP-LEVEL))))))
	 (SETQ LEVNUM 0)
	 (SETQ ALLOW T))
  (RUN1))
EXPR)

(DEFPROP STOP
 (LAMBDA N
  (BREAK1 NIL (NOT RUNF) (QUOTE CONNIVER-NOT-RUNNING--STOP) NIL NIL)
  (COND ((= N 0) (SETQ VAL NIL)) ((= N 1) (SETQ VAL (ARG 1))) (T (CERR WRONG # OF ARGS)))
  (SETQ PC (QUOTE POPJ))
  (ERR (QUOTE %%%STOP)))
EXPR)

(DEFPROP *STOP
 (LAMBDA NIL (SETQ PC (QUOTE U-LOSE)) (ERR (QUOTE %%%STOP)))
EXPR)

(DEFPROP U-LOSE
 (LAMBDA NIL (CERR ATTEMPT TO RUN A CONNIVER PROCESS WITH AN UNDEFINED PC) (QUOTE U-LOSE))
EXPR)

(DEFPROP CERR
 (LAMBDA(L A)
  (PRINT (QUOTE **ERROR**))
  (MAPC	(QUOTE
	 (LAMBDA(X)
	  (CPRIN1 (COND ((ATOM X) X) ((EQ (CAR X) (QUOTE /@)) (EVAL (CDR X) A)) (T X)))
	  (PRINC (QUOTE / ))))
	L)
  (CPRINT EXP)
  (PROG	NIL
   LP	(PRINT (QUOTE IN-LISP))
	(TERPRI)
	(PRINC (QUOTE /::))
	(COND ((EQ (SETQ ** (READ)) (QUOTE $P)) (RETURN NIL))
	      ((EQ (CAR **) (QUOTE RETURN)) (RETURN (EVAL (CADR **) A)))
	      (T (SETQ * (CPRINT (EVAL ** A)))))
	(SETQ ← **)
	(GO LP)))
FEXPR)

(DEFPROP EAR
 (LAMBDA NIL
  (PROGN (SETQ CINTERRUPT (CONS (QUOTE (LISTEN (QUOTE IN-CONNIVER))) CINTERRUPT))
	 (SETQ SERRLI ERRLIST)
	 (SETQ ERRLIST (QUOTE ((RUN1)))))
  (ERR (QUOTE ERROX)))
EXPR)

(DEFPROP TOP
 (LAMBDA NIL (PROGN (SETQ SERRLI ERRLIST) (SETQ ERRLIST (QUOTE ((START))))) (ERR (QUOTE ERRORX)))
EXPR)

(DEFPROP CINTERRUPT
 (LAMBDA (EXP) (NCONC (GET (QUOTE CINTERRUPT) (QUOTE VALUE)) (LIST EXP)))
EXPR)

(DEFPROP ALLOW
 (LAMBDA (L) (SETQ ALLOW (CAR L)))
FEXPR)

(COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)

(DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP DISPATCH
 (LAMBDA(EXP1 RETAG SAVE ALINK1)
  (COND	((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
	((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
	(T
	 (PROG (V F)
	       (SETQ F (CAR EXP1))
	  BEGIN
	       (COND ((ATOM F)
		      (COND ((SETQ V (GETL F (QUOTE (CINT CEXPR FEXPR FSUBR)))) (GO (CAR V)))
			    (T (SAVEUP)
			       (PROGN (SETQ UARGS (CDR EXP1)) (SETQ EARGS NIL))
			       (RETURN (QUOTE EVARGS)))))
		     ((EQ (CAR F) (QUOTE CLAMBDA))
		      (SAVEUP)
		      (BIND1 (QUOTE *BODY) (CDDR F))
		      (PROGN (SETQ VARS (CADR F)) (SETQ UARGS (CDR EXP1)))
		      (RETURN (QUOTE ARGB)))
		     ((EQ (CAR F) (QUOTE LAMBDA))
		      (SAVEUP)
		      (PROGN (SETQ UARGS (CDR EXP1)) (SETQ EARGS NIL))
		      (RETURN (QUOTE EVARGS)))
		     ((EQ (CAR F) (QUOTE *CLOSURE)) (SETQ F (CADR F)) (GO BEGIN))
		     (T (SETQ F (CERR UNKNOWN FUNCTION TYPE (/@ . EXP1))) (GO BEGIN)))
	  CINT (SAVEUP)
	       (RETURN (CADR V))
	  CEXPR
	       (SAVEUP)
	       (BIND1 (QUOTE *BODY) (CDADR V))
	       (PROGN (SETQ VARS (CAADR V)) (SETQ UARGS (CDR EXP1)))
	       (RETURN (QUOTE ARGB))
	  FEXPR
	  FSUBR
	       ((LAMBDA (*TOP) (SETQ VAL (EVAL EXP1))) ALINK1)
	       (RETURN RETAG)))))
EXPR)

(DEFPROP SAVEUP
 (LAMBDA NIL
  (PROGN (SETQ CLINK
	       (CONS (CONS (SAVEV) RETAG)
		     (COND ((NULL FRAME*) ($$$SETQ CHALOBV NIL) (CONS (CONS BVARS ALINK) (CONS EXP CLINK)))
			   (CHALOBV ($$$SETQ CHALOBV NIL) (CONS (CONS BVARS ALINK) (CDDR FRAME*)))
			   (T (CDR FRAME*)))))
	 (SETQ EXP EXP1)
	 (SETQ ALINK (COND ((EQ ALINK1 (QUOTE *TOP)) CLINK) (T ALINK1)))
	 (SETQ BVARS NIL)
	 (SETQ FRAME* NIL)))
EXPR)

(DEFPROP SAVEV
 (LAMBDA NIL (MAPCAR (QUOTE (LAMBDA (V) (CONS V (VALUE V)))) SAVE))
EXPR)

(COMMENT FUNCTION CALLS RETURN VIA "POPJ")

(DEFPROP POPJ
 (LAMBDA NIL (COND ((SETQ FRAME* CLINK) (RESTORE)) (T (QUOTE *STOP))))
EXPR)

(DEFPROP RESTORE
 (LAMBDA NIL
  (PROGN (SETQ BVARS (CAADR FRAME*))
	 (SETQ ALINK (CDADR FRAME*))
	 (SETQ EXP (CADDR FRAME*))
	 (SETQ CLINK (CDDDR FRAME*)))
  (REST1))
EXPR)

(DEFPROP REST1
 (LAMBDA NIL (MAPC (QUOTE (LAMBDA (X) (SET (CAR X) (CDR X)))) (CAAR FRAME*)) (CDAR FRAME*))
EXPR)

(DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP BIND1
 (LAMBDA (VAR VAL) (PROGN (SETQ BVARS (CONS (LIST VAR VAL) BVARS)) (SETQ CHALOBV T)))
EXPR)

(DEFPROP CLOSE
 (LAMBDA NIL
  (COND	((ATOM (CAR EXP)))
	((EQ (CAAR EXP) (QUOTE *CLOSURE)) (PROGN (SETQ ALINK (CADDAR EXP)) (SETQ CHALOBV T)))))
EXPR)

(COMMENT MOBY BINDER -- NORMAL FUNCTION LISTS)

(DEFPROP ARGB
 (LAMBDA NIL
  (COND	((NOT (OR# VARS UARGS)) (CLOSE) (QUOTE AUXB))
	((AND# VARS UARGS)
	 (COND ((ATOM (CAR VARS))
		(COND ((EQ (CAR VARS) (QUOTE "OPTIONAL")) (SETQ VARS (CDR VARS)) (OPTMATCH))
		      ((EQ (CAR VARS) (QUOTE "REST")) (SETQ VARS (CDR VARS)) (RESTMATCH))
		      (T (DISPATCH (CAR UARGS) (QUOTE ARGB1) (QUOTE (VARS UARGS)) ALINK))))
	       ((AND# (EQ (CAAR VARS) (QUOTE QUOTE)) (ATOM (CADAR VARS))) (ARGQ))
	       (T (CERR BAD DECLARATION))))
	((AND# VARS (OR# (EQ (CAR VARS) (QUOTE "OPTIONAL")) (EQ (CAR VARS) (QUOTE "REST")))) (CLOSE) (FINVAR))
	(T (CERR WRONG # OF ARGS))))
EXPR)

(DEFPROP ARGB1
 (LAMBDA NIL (BIND1 (CAR VARS) VAL) (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS))) (QUOTE ARGB))
EXPR)

(DEFPROP ARGQ
 (LAMBDA NIL
  (BIND1 (CADAR VARS) (CAR UARGS))
  (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
  (QUOTE ARGB))
EXPR)

(COMMENT BIND UP "OPTIONAL"S AND "REST"S)

(DEFPROP OPTMATCH
 (LAMBDA NIL
  (COND	((NULL UARGS) (CLOSE) (COND ((NULL VARS) (QUOTE AUXB)) (T (QUOTE FINVAR))))
	((ATOM (CAR VARS))
	 (COND ((EQ (CAR VARS) (QUOTE "OPTIONAL")) (SETQ VARS (CDR VARS)) (QUOTE OPTMATCH))
	       ((EQ (CAR VARS) (QUOTE "REST")) (SETQ VARS (CDR VARS)) (QUOTE RESTMATCH))
	       (T (DISPATCH (CAR UARGS) (QUOTE OPTMATCH1) (QUOTE (VARS UARGS)) ALINK))))
	((EQ (CAAR VARS) (QUOTE QUOTE))
	 (COND ((ATOM (CADAR VARS))
		(BIND1 (CADAR VARS) (CAR UARGS))
		(PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
		(QUOTE OPTMATCH))
	       (T (CERR BAD DECLARATION))))
	((ATOM (CAAR VARS)) (DISPATCH (CAR UARGS) (QUOTE OPTMATCH1) (QUOTE (VARS UARGS)) ALINK))
	((AND# (EQ (CAAAR VARS) (QUOTE QUOTE)) (ATOM (CADAAR VARS)))
	 (BIND1 (CADAAR VARS) (CAR UARGS))
	 (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
	 (QUOTE OPTMATCH))
	(T (CERR BAD DECLARATION))))
EXPR)

(DEFPROP OPTMATCH1
 (LAMBDA NIL
  (BIND1 (COND ((ATOM (CAR VARS)) (CAR VARS)) (T (CAAR VARS))) VAL)
  (PROGN (SETQ VARS (CDR VARS)) (SETQ UARGS (CDR UARGS)))
  (QUOTE OPTMATCH))
EXPR)

(DEFPROP RESTMATCH
 (LAMBDA NIL
  (COND	((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
	((AND# (EQ (CAAR VARS) (QUOTE QUOTE)) (ATOM (CADAR VARS)))
	 (BIND1 (CADAR VARS) UARGS)
	 (CLOSE)
	 (QUOTE AUXB))
	(T (CERR BAD DECLARATION))))
EXPR)

(DEFPROP EVREST
 (LAMBDA NIL
  (COND	((NULL UARGS) (BIND1 (CAR VARS) (REVERSE EARGS)) (CLOSE) (QUOTE AUXB))
	(T (DISPATCH (CAR UARGS) (QUOTE EVREST1) (QUOTE (VARS UARGS EARGS)) ALINK))))
EXPR)

(DEFPROP EVREST1
 (LAMBDA NIL (PROGN (SETQ UARGS (CDR UARGS)) (SETQ EARGS (CONS VAL EARGS))) (QUOTE EVREST))
EXPR)

(COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)

(DEFPROP FINVAR
 (LAMBDA NIL
  (COND	((NULL VARS) (QUOTE AUXB))
	((ATOM (CAR VARS))
	 (COND ((EQ (CAR VARS) (QUOTE "OPTIONAL")) (SETQ VARS (CDR VARS)) (QUOTE FINVAR))
	       ((EQ (CAR VARS) (QUOTE "REST"))
		(SETQ VARS (CDR VARS))
		(COND ((ATOM (CAR VARS)) (BIND1 (CAR VARS) NIL) (QUOTE AUXB))
		      ((AND# (EQ (CAAR VARS) (QUOTE QUOTE)) (ATOM (CADAR VARS)))
		       (BIND1 (CADAR VARS) NIL)
		       (QUOTE AUXB))
		      (T (CERR BAD DECLARATION))))
	       (T (BIND1 (CAR VARS) (QUOTE *UNASSIGNED)) (SETQ VARS (CDR VARS)) (QUOTE FINVAR))))
	((EQ (CAAR VARS) (QUOTE QUOTE))
	 (COND ((ATOM (CADAR VARS))
		(BIND1 (CADAR VARS) (QUOTE *UNASSIGNED))
		(SETQ VARS (CDR VARS))
		(QUOTE FINVAR))
	       (T (CERR BAD DECLARATION))))
	((ATOM (CAAR VARS)) (DISPATCH (CADAR VARS) (QUOTE FINVAR1) (QUOTE (VARS)) (QUOTE *TOP)))
	((AND# (EQ (CAAAR VARS) (QUOTE QUOTE)) (ATOM (CADAAR VARS)))
	 (DISPATCH (CADAR VARS) (QUOTE FINVAR2) (QUOTE (VARS)) (QUOTE *TOP)))
	(T (CERR BAD DECLARATION))))
EXPR)

(DEFPROP FINVAR1
 (LAMBDA NIL (BIND1 (CAAR VARS) VAL) (FINVAR3))
EXPR)

(DEFPROP FINVAR2
 (LAMBDA NIL (BIND1 (CADAAR VARS) VAL) (FINVAR3))
EXPR)

(DEFPROP FINVAR3
 (LAMBDA NIL (SETQ VARS (CDR VARS)) (QUOTE FINVAR))
EXPR)

(COMMENT BINDS "AUX" VARIABLES)

(DEFPROP AUXB
 (LAMBDA NIL
  (SETQ BODY (BODY))
  (COND	((NULL BODY) (POPJ))
	((EQ (CAR BODY) (QUOTE "AUX")) (SETQ VARS (CADR BODY)) (QUOTE AUXB1))
	(T (QUOTE LINE))))
EXPR)

(DEFPROP AUXB1
 (LAMBDA NIL
  (COND	((NULL VARS) (SETQ BODY (CDDR (BODY))) (QUOTE LINE))
	((ATOM (CAR VARS)) (BIND1 (CAR VARS) (QUOTE *UNASSIGNED)) (SETQ VARS (CDR VARS)) (QUOTE AUXB1))
	((AND# (ATOM (CAAR VARS)) (CDAR VARS))
	 (DISPATCH (CADAR VARS) (QUOTE AUXB2) (QUOTE (VARS)) (QUOTE *TOP)))
	(T (CERR BAD DECLARATION))))
EXPR)

(DEFPROP AUXB2
 (LAMBDA NIL (BIND1 (CAAR VARS) VAL) (SETQ VARS (CDR VARS)) (QUOTE AUXB1))
EXPR)

(DEFPROP CPROG
 (LAMBDA NIL (BIND1 (QUOTE *BODY) (CDR EXP)) (QUOTE AUXB))
EXPR)

(DEFPROP PROG
 CPROG
CINT)

(DEFPROP PROG
 PROGB
BACKTRACE)

(DEFPROP PROGBIND
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE PROGB1) NIL ALINK))
EXPR)

(DEFPROP PROGBIND
 PROGBIND
CINT)

(DEFPROP PROGBIND
 PROGBINDB
BACKTRACE)

(DEFPROP PROGB1
 (LAMBDA NIL (BIND1 (QUOTE *BODY) (CONS (QUOTE "AUX") (CONS (SETQ VARS VAL) (CDDR EXP)))) (QUOTE AUXB1))
EXPR)

(COMMENT BASIC PROG ITERATION LOOP)

(DEFPROP LINE
 (LAMBDA NIL (COND ((NULL BODY) (POPJ)) (T (DISPATCH (CAR BODY) (QUOTE LINE1) (QUOTE (BODY)) (QUOTE *TOP)))))
EXPR)

(DEFPROP LINE1
 (LAMBDA NIL (SETQ BODY (CDR BODY)) (QUOTE LINE))
EXPR)

(COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)

(DEFPROP EVARGS
 (LAMBDA NIL
  (COND	((NULL UARGS) ((LAMBDA (*TOP) (SETQ VAL (APPLY# (CAR EXP) (REVERSE EARGS)))) ALINK) (POPJ))
	(T (DISPATCH (CAR UARGS) (QUOTE ARGS1) (QUOTE (UARGS EARGS)) ALINK))))
EXPR)

(DEFPROP ARGS1
 (LAMBDA NIL (PROGN (SETQ UARGS (CDR UARGS)) (SETQ EARGS (CONS VAL EARGS))) (QUOTE EVARGS))
EXPR)

(COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)

(DEFPROP CCOND
 (LAMBDA NIL (SETQ UARGS (CDR EXP)) (CONDLP))
EXPR)

(DEFPROP CONDLP
 (LAMBDA NIL (COND ((NULL UARGS) (POPJ)) (T (DISPATCH (CAAR UARGS) (QUOTE COND1) (QUOTE (UARGS)) ALINK))))
EXPR)

(DEFPROP COND1
 (LAMBDA NIL
  (COND (VAL (BIND1 (QUOTE *BODY) (CDAR UARGS)) (QUOTE AUXB)) (T (SETQ UARGS (CDR UARGS)) (QUOTE CONDLP))))
EXPR)

(DEFPROP COND
 CCOND
CINT)

(DEFPROP COND
 CONDB
BACKTRACE)

(DEFPROP IAND
 (LAMBDA NIL
  (COND	((NULL (SETQ EXP (CDR EXP))) (OR# VAL ($$$SETQ VAL T)) (POPJ))
	((DISPATCH (CAR EXP) (QUOTE IAND1) (QUOTE (EXP)) (QUOTE *TOP)))))
EXPR)

(DEFPROP IAND1
 (LAMBDA NIL (COND (VAL (QUOTE IAND)) ((QUOTE POPJ))))
EXPR)

(DEFPROP AND
 IAND
CINT)

(DEFPROP IOR
 (LAMBDA NIL
  (COND	((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
	((DISPATCH (CAR EXP) (QUOTE IOR1) (QUOTE (EXP)) (QUOTE *TOP)))))
EXPR)

(DEFPROP IOR1
 (LAMBDA NIL (COND (VAL (POPJ)) (T (QUOTE IOR))))
EXPR)

(DEFPROP OR
 IOR
CINT)

(COMMENT USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS)

(DEFPROP CGO
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE GO1) NIL ALINK))
EXPR)

(DEFPROP GO1
 (LAMBDA NIL
  (COND	((ATOM VAL)
	 (PROG (FR TAG B)
	       (PROGN (SETQ FR ALINK) (SETQ TAG (QUOTE (/: FOO))))
	       (RPLACA (CDR TAG) VAL)
	  LP   (COND ((NULL FR) (SETQ VAL (CERR TAG NOT FOUND)) (QUOTE GO1))
		     ((SETQ B (ASSOC (QUOTE *BODY) (BVARS FR)))
		      (COND
		       ((SETQ B (MEMBER# TAG (CADR B)))
			(SETQ FRAME* FR)
			(RESTORE)
			(SETQ BODY B)
			(RETURN (QUOTE LINE))))))
	       (SETQ FR (CLINK FR))
	       (GO LP)))
	((EQ (CAR VAL) (QUOTE *TAG)) (SETQ FRAME* (CADDR VAL)) (RESTORE))
	(T (SETQ VAL (CERR BAD TAG)) (QUOTE GO1))))
EXPR)

(DEFPROP GO
 CGO
CINT)

(DEFPROP CEXIT
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE EXIT1) NIL ALINK))
EXPR)

(DEFPROP EXIT1
 (LAMBDA NIL
  (SETQ TEM VAL)
  (COND	((CDDR EXP) (DISPATCH (CADDR EXP) (QUOTE EXIT2) (QUOTE (TEM)) ALINK))
	(T
	 (PROG (FR)
	       (SETQ FR ALINK)
	  LP   (COND ((NULL FR) (CERR EXIT FROM WHAT?))
		     ((ASSOC (QUOTE *BODY) (BVARS FR)) (SETQ CLINK (CLINK FR)) (RETURN (POPJ))))
	       (SETQ FR (CLINK FR))
	       (GO LP)))))
EXPR)

(DEFPROP EXIT2
 (LAMBDA NIL (PROGN (SETQ CLINK (CLINK (FR VAL))) (SETQ VAL TEM)) (POPJ))
EXPR)

(DEFPROP EXIT
 CEXIT
CINT)

(DEFPROP CRETURN
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE RETURN1) NIL ALINK))
EXPR)

(DEFPROP RETURN1
 (LAMBDA NIL
  (PROG	(FR)
	(SETQ FR ALINK)
   LP	(COND ((NULL FR) (CERR RETURN FROM WHAT?))
	      ((AND# (ASSOC (QUOTE *BODY) (BVARS FR)) (NOT (EQ (CAR (EXP FR)) (QUOTE COND))))
	       (SETQ CLINK (CLINK FR))
	       (RETURN (POPJ))))
	(SETQ FR (CLINK FR))
	(GO LP)))
EXPR)

(DEFPROP RETURN
 CRETURN
CINT)

(DEFPROP CDISMISS
 (LAMBDA NIL
  (COND	((CDR EXP) (SETQ TEM NIL) (DISPATCH (CADR EXP) (QUOTE EXIT2) (QUOTE (TEM)) ALINK))
	(T (SETQ VAL NIL) (RETURN1))))
EXPR)

(DEFPROP DISMISS
 CDISMISS
CINT)

(DEFPROP CONTINUE
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CONT1) NIL ALINK))
EXPR)

(DEFPROP CONTINUE
 CONTINUE
CINT)

(DEFPROP CONT1
 (LAMBDA NIL
  (SETQ TEM VAL)
  (COND	((CDDR EXP) (DISPATCH (CADDR EXP) (QUOTE CONT2) (QUOTE (TEM)) ALINK))
	(T (PROGN (SETQ VAL NIL) (SETQ FRAME* (FR TEM))) (RESTORE))))
EXPR)

(DEFPROP CONT2
 (LAMBDA NIL (SETQ FRAME* (FR TEM)) (RESTORE))
EXPR)

(COMMENT RELATIVE EVALUATORS)

(DEFPROP ICEVAL
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CEVAL1) NIL ALINK))
EXPR)

(DEFPROP CEVAL1
 (LAMBDA NIL
  (SETQ TEM1 VAL)
  (COND	((CDDR EXP) (DISPATCH (CADDR EXP) (QUOTE CEVAL2) (QUOTE (TEM1)) ALINK))
	(T (SETQ VAL (FRAME)) (QUOTE CEVAL2))))
EXPR)

(DEFPROP CEVAL2
 (LAMBDA NIL (DISPATCH TEM1 (QUOTE POPJ) NIL (FR VAL)))
EXPR)

(DEFPROP CEVAL
 (LAMBDA N
  ((LAMBDA (PC EXP ALINK) (PROG (CLINK FRAME* BVARS CHALOBV RUNF) (RETURN (RUN1))))
   (QUOTE ICEVAL)
   (LIST (QUOTE CEVAL) (LIST (QUOTE QUOTE) (ARG 1)))
   (COND ((> N 1) (FR (ARG 2))) (T ALINK))))
EXPR)

(DEFPROP CEVAL
 ICEVAL
CINT)

(DEFPROP CEVAL
 CEVALB
BACKTRACE)

(DEFPROP ICALL
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CALL1) NIL ALINK))
EXPR)

(DEFPROP CALL1
 (LAMBDA NIL (DISPATCH (CONS VAL (CDDR EXP)) (QUOTE POPJ) NIL ALINK))
EXPR)

(DEFPROP CALL
 ICALL
CINT)

(DEFPROP INVOKE
 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE TRY1) NIL ALINK))
EXPR)

(DEFPROP INVOKE
 INVOKE
CINT)

(DEFPROP TRY1
 (LAMBDA NIL (SETQ TEM VAL) (DISPATCH (CADDR EXP) (QUOTE TRY2) (QUOTE (TEM)) ALINK))
EXPR)

(DEFPROP TRY2
 (LAMBDA NIL
  (PROGN (SETQ EXP (LIST TEM VAL)) (SETQ FRAME* NIL))
  (PROG	(AL METHPAT)
	(COND ((NULL (SETQ AL (MATCH (SETQ METHPAT (PATTERN TEM)) VAL))) (RETURN (POPJ)))
	      (T (SETQ BVARS
		       (NCONC (LIST (LIST (QUOTE *CALLPAT) VAL)
				    (LIST (QUOTE *METHPAT) METHPAT)
				    (LIST (QUOTE *CALLALIST) (CADR AL))
				    (LIST (QUOTE *BODY) (TEXT TEM)))
			      (CAR AL)))
		 (CLOSE)
		 (RETURN (QUOTE AUXB))))))
EXPR)

(DEFPROP TEXT
 (LAMBDA(METH)
  (COND	((ATOM METH) (TEXT (GET METH (QUOTE DATUM))))
	((EQ (CAR METH) (QUOTE *CLOSURE)) (TEXT (CADR METH)))
	(T (CADDDR METH))))
EXPR)

(DEFPROP FR
 (LAMBDA(E)
  (COND	((EQ (CAR E) (QUOTE *FRAME)) (CADR E))
	((EQ (CAR E) (QUOTE *TAG)) (CADDR E))
	((EQ (CAR E) (QUOTE *CLOSURE)) (CADDR E))
	((EQ (CAR E) (QUOTE *AU-REVOIR)) (CADR E))
	(T (CERR BAD FRAME SUPPLIED))))
EXPR)

(COMMENT IDENTIFIER MANIPULATORS)

(DEFPROP VFRAME
 (LAMBDA N
  (PROG	(FR LOC)
	(SETQ FR (COND ((= N 1) ALINK) ((= N 2) (FR (ARG 2))) (T (CERR WRONG # OF ARGS))))
   LP	(COND ((NULL FR) (RETURN NIL))
	      ((SETQ LOC (ASSOC (ARG 1) (BVARS FR))) (RETURN (LIST (QUOTE *FRAME) (CHAUX FR) LOC))))
	(SETQ FR (ALINK FR))
	(GO LP)))
EXPR)

(DEFPROP VLOC
 (LAMBDA N
  (PROG	(FR LOC)
	(SETQ FR
	      (COND ((= N 1) (COND ((SETQ LOC (ASSOC (ARG 1) BVARS)) (RETURN LOC))) ALINK)
		    ((= N 2) (FR (ARG 2)))
		    (T (CERR WRONG # OF ARGS))))
   LP	(COND ((NULL FR) (RETURN (ASSOC (ARG 1) GLOBALS))) ((SETQ LOC (ASSOC (ARG 1) (BVARS FR))) (RETURN LOC)))
	(SETQ FR (ALINK FR))
	(GO LP)))
EXPR)

(DEFPROP RVALUE
 (LAMBDA N
  ((LAMBDA(LOC)
    (COND (LOC (COND ((CDDR LOC) (APPLY# (CADDR LOC) (LIST (QUOTE RVALUE) LOC)))) (CADR LOC))
	  (T (CERR UNBOUND VARIABLE (QUOTE (ARG 1))))))
   (COND ((= N 1) (VLOC (ARG 1))) ((= N 2) (VLOC (ARG 1) (ARG 2))) (T (CERR WRONG # OF ARGS)))))
EXPR)

(DECLARE (SPECIAL ID))

(DEFPROP IVAL
 (LAMBDA(ID FR)
  (PROG	(ANS)
	(COND ((EQ FR (QUOTE *TOP)) (COND ((SETQ ANS (ASSOC ID BVARS)) (GO FOUND)) (T (SETQ FR ALINK)))))
   LP	(COND ((NULL FR)
	       (COND ((SETQ ANS (ASSOC ID GLOBALS)) (GO FOUND)) (T (RETURN (CERR UNBOUND VARIABLE (/@ . ID))))))
	      ((SETQ ANS (ASSOC ID (BVARS FR))) (GO FOUND)))
	(SETQ FR (ALINK FR))
	(GO LP)
   FOUND
	(COND ((CDDR ANS) (APPLY# (CADDR ANS) (LIST (QUOTE /,) ANS))))
	(COND ((EQ (SETQ ANS (CADR ANS)) (QUOTE *UNASSIGNED)) (RETURN (CERR UNASSIGNED VARIABLE (/@ . ID)))))
	(RETURN ANS)))
EXPR)

(DECLARE (UNSPECIAL ID))

(DEFPROP ICSETQ
 (LAMBDA NIL (SETQ UARGS EXP) (CSETQ0))
EXPR)

(DEFPROP CSETQ0
 (LAMBDA NIL
  (COND	((CDR UARGS)
	 (COND ((AND# (ATOM (CADR UARGS)) (CDDR UARGS))
		(DISPATCH (CADDR UARGS) (QUOTE CSETQ1) (QUOTE (UARGS)) ALINK))
	       (T (CERR BAD CALL) (POPJ))))
	(T (POPJ))))
EXPR)

(DEFPROP CSETQ1
 (LAMBDA NIL
  ((LAMBDA(LOC)
    (COND (LOC (COND ((CDDR LOC) (APPLY# (CADDR LOC) (LIST (QUOTE CSET) LOC VAL)))) (RPLACA (CDR LOC) VAL))
	  (T (SETQ GLOBALS (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
   (VLOC (CADR UARGS)))
  (SETQ UARGS (CDDR UARGS))
  (QUOTE CSETQ0))
EXPR)

(DEFPROP CSETQ
 (LAMBDA (L) (CSET (CAR L) (EVAL (CADR L))))
FEXPR)

(DEFPROP CSETQ
 ICSETQ
CINT)

(DEFPROP CSET
 (LAMBDA N
  ((LAMBDA(LOC)
    (COND (LOC (COND ((CDDR LOC) (APPLY# (CADDR LOC) (LIST (QUOTE CSET) LOC (ARG 2)))))
	       (RPLACA (CDR LOC) (ARG 2)))
	  (T (SETQ GLOBALS (CONS (LIST (ARG 1) (ARG 2)) GLOBALS))))
    (ARG 2))
   (COND ((= N 2) (VLOC (ARG 1))) ((= N 3) (VLOC (ARG 1) (ARG 3))) (T (CERR WRONG # OF ARGS)))))
EXPR)

(DEFPROP UNASSIGN
 (LAMBDA (VAR) (CSET VAR (QUOTE *UNASSIGNED)))
EXPR)

(COMMENT FRAME CONSTRUCTORS)

(DEFPROP CHAUX
 (LAMBDA(FR)
  (COND ((NULL FR) NIL) ((EQ (CDAR FR) (QUOTE AUXB1)) (CERR ATTEMPT TO RETURN INCOMPLETE FRAME)) (T FR)))
EXPR)

(DEFPROP TAG
 (LAMBDA(NAME)
  (PROG	(FR B TAG)
	(PROGN (SETQ FR ALINK) (SETQ TAG (QUOTE (/: FOO))))
	(RPLACA (CDR TAG) NAME)
   LP	(COND ((NULL FR) (RETURN NIL))
	      ((SETQ B (ASSOC (QUOTE *BODY) (BVARS FR)))
	       (COND
		((SETQ B (MEMBER# TAG (CADR B)))
		 (CHAUX FR)
		 (RETURN
		  (LIST (QUOTE *TAG) NAME (CONS (CONS (LIST (CONS (QUOTE BODY) B)) (QUOTE LINE)) (CDR FR))))))))
	(SETQ FR (CLINK FR))
	(GO LP)))
EXPR)

(DEFPROP ACTBLOCK
 (LAMBDA NIL
  (PROG	(FR B)
	(SETQ FR ALINK)
   LP	(COND ((NULL FR) (RETURN NIL))
	      ((SETQ B (ASSOC (QUOTE *BODY) (BVARS FR)))
	       (CHAUX FR)
	       (COND ((EQ (CAR B) (QUOTE "AUX")) (SETQ B (CDDR B))))
	       (RETURN
		(LIST (QUOTE *TAG)
		      (QUOTE *ACTBLOCK)
		      (CONS (CONS (LIST (CONS (QUOTE BODY) B)) (QUOTE LINE)) (CDR FR))))))
	(SETQ FR (CLINK FR))
	(GO LP)))
EXPR)

(DEFPROP ACCESS
 (LAMBDA N
  (LIST	(QUOTE *FRAME)
	(CHAUX (COND ((= N 0) (ALINK ALINK)) ((= N 1) (ALINK (FR (ARG 1)))) (T (CERR WRONG # OF ARGS))))))
EXPR)

(DEFPROP CONTROL
 (LAMBDA N
  (LIST	(QUOTE *FRAME)
	(CHAUX (COND ((= N 0) (CLINK ALINK)) ((= N 1) (CLINK (FR (ARG 1)))) (T (CERR WRONG # OF ARGS))))))
EXPR)

(DEFPROP CLOSURE
 (LAMBDA N
  (COND ((OR# (< N 1) (> N 2)) (CERR WRONG # OF ARGS)))
  (LIST (QUOTE *CLOSURE) (ARG 1) (CHAUX (COND ((= N 2) (FR (ARG 2))) (T ALINK)))))
EXPR)

(DEFPROP FRAME
 (LAMBDA NIL (LIST (QUOTE *FRAME) (CHAUX ALINK)))
EXPR)

(COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)

(DEFPROP SETACCESS
 (LAMBDA (T1 S) (PROGN (SETQ T1 (FR T1)) (SETQ S (FR S))) (RPLACD (CADR T1) S) (QUOTE BOOM!))
EXPR)

(DEFPROP SETCONTROL
 (LAMBDA (T1 S) (PROGN (SETQ T1 (FR T1)) (SETQ S (FR S))) (RPLACD (CDDR T1) S) (QUOTE BOOM!))
EXPR)

(COMMENT DEBUGGING AIDS)

(DEFPROP EXPRESSION
 (LAMBDA (F) (EXP (FR F)))
EXPR)

(DEFPROP BACKTRACE
 (LAMBDA N
  (PROG	(FR E B M TEM)
	(SETQ FR (FRAME))
	(COND ((= N 0) (SETQ M 777777)) (T (SETQ M (ARG 1))))
	(COND ((= N 2) (SETQ TEM (ARG 2))))
   LP	(COND ((OR# (NULL (CADR FR)) (= M 0)) (RETURN (QUOTE END-OF-BACKTRACE))))
	(SETQ E (EXPRESSION FR))
	(COND ((SETQ B (GET (CAR E) (QUOTE BACKTRACE))) (APPLY# B (LIST FR (CDR E)))) (T (CPRINT E)))
	(COND (TEM (CPRIN1 (CAADR FR))))
	(SETQ FR (CONTROL FR))
	(SETQ M (SUB1 M))
	(GO LP)))
EXPR)

(DEFPROP LISTENB
 (LAMBDA(FR ARG)
  (PRINT (IVAL (QUOTE EAR) (CADR FR)))
  (CPRIN1 (IVAL (QUOTE MESSAGE) (CADR FR)))
  (PRINC (QUOTE / )))
EXPR)

(DEFPROP LISTEN
 ((MESSAGE) "AUX"
	    ((EAR (GENLEV)))
	    (ALLOW T)
	    (CPRINT MESSAGE)
	    (PROGBIND (LIST (/, EAR) (QUOTE LOOP))
		      (CSET EAR (TAG (QUOTE EAR)))
		      (CSETQ LOOP (TAG (QUOTE LOOP)))
		      (/: EAR)
		      (PRINT EAR)
		      (/: LOOP)
		      (SETQ ← **)
		      (/@ PRINT (QUOTE //))
		      (SET (QUOTE *) (CEVAL (SETQ ** (READ))))
		      (/@ CPRINT *)
		      (GO LOOP)))
CEXPR)

(DEFPROP LISTEN
 LISTENB
BACKTRACE)

(DEFPROP CONDB
 (LAMBDA (FR ARG) (PRINT (QUOTE COND)))
EXPR)

(DEFPROP PROGB
 (LAMBDA (FR ARG) (PRINT (QUOTE PROG)))
EXPR)

(DEFPROP CEVALB
 (LAMBDA (FR ARG) (COND (TEM (PRINT (QUOTE CEVAL)))))
EXPR)

(DEFPROP UPDATEB
 (LAMBDA (FR ARG) NIL)
EXPR)

(DEFPROP UPDATE
 UPDATEB
BACKTRACE)

(DEFPROP SETB
 (LAMBDA (FR ARG) (OR# (MEMBER# (CAR ARG) (QUOTE ((QUOTE *) (QUOTE **)))) (PRINT (CONS (QUOTE SET) ARG))))
EXPR)

(DEFPROP SET
 SETB
BACKTRACE)

(DEFPROP PROGBINDB
 (LAMBDA (FR ARG) (PRINT (QUOTE PROGBIND)))
EXPR)

(COMMENT USER INTERFACE)

(DEFPROP CDEFUN
 (LAMBDA (L) (PUTPROP (CAR L) (CDR L) (QUOTE CEXPR)) (CAR L))
FEXPR)

(DEFPROP GENLEV
 (LAMBDA NIL (READLIST (APPEND (QUOTE (E A R -)) (EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
EXPR)

(DEFPROP /:
 (LAMBDA (L) L)
FEXPR)

(DEFPROP /:
 CP-MACR
CPRINT)

(DEFPROP /@
 (LAMBDA (\L) (EVAL \L))
FEXPR)

(DEFPROP /@
 CP-!"
CPRINT)

(DEFPROP /!
 CP-MACR
CPRINT)

(DEFPROP /,
 (LAMBDA (L) (IVAL (CAR L) *TOP))
FEXPR)

(DEFPROP /,
 CP-MACR
CPRINT)

(DEFPROP CPRIN1
 (LAMBDA(X)
  (PROG	(Y)
	(COND ((PATOM X) (PRIN1 X) (RETURN X))
	      ((AND# (LITATOM (CAR X)) (NOT (NUMBERP (CAR X))) ($$$SETQ Y (GET (CAR X) (QUOTE CPRINT))))
	       (APPLY# Y X)
	       (RETURN X)))
	(SETQ Y X)
	(PRINC (QUOTE /())
   PLOOP
	(CPRIN1 (CAR Y))
	(COND ((NULL (SETQ Y (CDR Y))) (PRINC (QUOTE /))) (RETURN X))
	      ((PATOM Y) (PRINC (QUOTE / /./ )) (PRIN1 Y) (PRINC (QUOTE /))) (RETURN X)))
	(PRINC (QUOTE / ))
	(GO PLOOP)))
EXPR)

(DEFPROP CPRINT
 (LAMBDA (X) (TERPRI) (CPRIN1 X) (PRINC (QUOTE / )) X (TERPRI))
EXPR)

(DEFPROP CP-MACR
 (LAMBDA (E) (PRINC (CAR E)) (PRIN1 (CADR E)))
FEXPR)

(DEFPROP CP-QUOTE
 (LAMBDA (E) (PRINC (QUOTE /')) (CPRIN1 (CADR E)))
FEXPR)

(DEFPROP QUOTE
 CP-QUOTE
CPRINT)

(DEFPROP CP-*TAG
 (LAMBDA(TAG)
  (PRINC (QUOTE /())
  (PRIN1 (CAR TAG))
  (PRINC (QUOTE / ))
  (CPRIN1 (CADR TAG))
  (PRINC (QUOTE / ))
  (CPRIN1 (EXP (CADDR TAG)))
  (PRINC (QUOTE /))))
FEXPR)

(DEFPROP *TAG
 CP-*TAG
CPRINT)

(DEFPROP *CLOSURE
 CP-*TAG
CPRINT)

(DEFPROP CP-*FRAME
 (LAMBDA(FRAME)
  (PRINC (QUOTE /())
  (PRIN1 (CAR FRAME))
  (PRINC (QUOTE / ))
  (CPRIN1 (EXP (CADR FRAME)))
  (PRINC (QUOTE /))))
FEXPR)

(DEFPROP *FRAME
 CP-*FRAME
CPRINT)

(DEFPROP *AU-REVOIR
 CP-*FRAME
CPRINT)

(DEFPROP CP-MATCH
 (LAMBDA (E) (PRINC (CAR E)) (COND ((CDDR E) (CPRIN1 (CDR E))) ((CADR E) (CPRIN1 (CADR E)))))
FEXPR)

(DEFPROP /!'
 CP-MATCH
CPRINT)

(DEFPROP /!@
 CP-MATCH
CPRINT)

(DEFPROP CP-!"
 (LAMBDA (E) (PRINC (CAR E)) (CPRIN1 (CDR E)))
FEXPR)

(DEFPROP COLMAC
 (LAMBDA NIL (LIST (QUOTE /:) (READ)))
EXPR)

(DEFPROP COMMAC
 (LAMBDA NIL (LIST (QUOTE /,) (READ)))
EXPR)

(DEFPROP ATMAC
 (LAMBDA NIL (CONS (QUOTE /@) (READ)))
EXPR)

(DEFPROP EXMAC
 (LAMBDA NIL
  (PROG	(C F)
	(SETQ C (NXTCHR))
	(COND ((EQ C (QUOTE $)) (TYI) (RETURN ((LAMBDA (OBARRAY) (READ)) (GET (QUOTE CONNIVER) (QUOTE ARRAY)))))
	      ((SETQ F (ASSOC C (QUOTE ((" /!") (/@ /!@))))) (TYI) (RETURN (CONS (CADR F) (READ))))
	      ((SETQ F (ASSOC C (QUOTE ((? /!?) (/' /!') (> /!>) (/, /!/,) (< /!<) (/; /!;)))))
	       (TYI)
	       (SETQ F (CADR F)))
	      (T (PRINT (LIST (QUOTE BAD) (QUOTE /!) (QUOTE MACRO) C)) (ERR (QUOTE ERRORX))))
	(RETURN (COND ((SEPARATOR (NXTCHR)) (LIST F NIL)) ((ATOM (SETQ C (READ))) (LIST F C)) (T (CONS F C))))))
EXPR)

(DEFPROP NXTCHR
 (LAMBDA NIL (INTERN (ASCII (TYIPEEK))))
EXPR)

(DEFPROP SEPARATOR
 (LAMBDA (CHAR) (MEMQ# CHAR (QUOTE (/  /	 /) /] /⎇ /
 /
))))
EXPR)

(DECLARE (SPECIAL CFRAMES
		  CNUM
		  CONTEXT
		  DATUM
		  CMARKERS
		  TYPE
		  PATTERN
		  GLOBAL
		  INCCON
		  NUMACT
		  NUMCON
		  *CNUM
		  *IF-ADDEDS
		  *IF-NEEDEDS
		  *IF-REMOVEDS
		  *INDEXTHRESHOLD
		  *ITEMS
		  NEW)
	 (*FEXPR /!" CDEFUN CERR CSETQ /: /, GCCON IF-ADDED IF-NEEDED IF-REMOVED)
	 (*LEXPR BIND
		 ABSENT
		 ADD
		 CEVAL
		 CFRAME
		 CSET
		 VLOC
		 DGET
		 DGET+
		 DPUT
		 DPUT+
		 DREM
		 DREM+
		 FETCH
		 FETCHI
		 FETCHM
		 INSERT
		 KILL
		 MATCH
		 NOTE
		 OBJECT
		 POP-CONTEXT
		 PRESENT
		 DATA-INIT
		 PUSH-CONTEXT
		 REAL
		 REALIZE
		 REMOVE
		 RVALUE
		 UNREAL
		 UNREALIZE)
	 (*EXPR ARGS DATUM CMARKERS PATTERN)
	 (**ARRAY FRAMES RFRAMES))

(SETQ *INDEXTHRESHOLD 12)

(DEFPROP OBJECT
 (LAMBDA N (LIST (QUOTE *OBJECT) (COND ((= N 0) NIL) ((= N 1) (ARG 1)) ((TMA)))))
EXPR)

(DEFPROP TMA
 (LAMBDA NIL (CERR TOO MANY ARGUMENTS))
EXPR)

(DEFPROP TFA
 (LAMBDA NIL (CERR TOO FEW ARGUMENTS))
EXPR)

(DECLARE (UNSPECIAL CMARKERS TYPE))

(DEFPROP MAKE-METHOD
 (LAMBDA(TYPE BOD)
  (PROG	(FIRST OLDM CMARKERS)
	(COND ((ATOM (SETQ FIRST (CAR BOD)))
	       (SETQ CMARKERS (COND ((SETQ OLDM (GET FIRST (QUOTE DATUM))) (CDR (CMARKERS OLDM)))))
	       (PUTPROP FIRST (NCONC (LIST TYPE FIRST (CADR BOD) (CDDR BOD)) CMARKERS) (QUOTE DATUM))
	       (RETURN FIRST))
	      ((RETURN (LIST TYPE NIL FIRST (CDR BOD)))))))
EXPR)

(DECLARE (SPECIAL CMARKERS TYPE))

(DEFPROP IF-NEEDED
 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-NEEDED) A))
FEXPR)

(DEFPROP IF-ADDED
 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-ADDED) A))
FEXPR)

(DEFPROP IF-REMOVED
 (LAMBDA (A) (MAKE-METHOD (QUOTE IF-REMOVED) A))
FEXPR)

(DEFPROP DATA-INIT
 (LAMBDA K
  ((LAMBDA(N M)
    (COND
     ((BOUNDP (QUOTE NUMACT))
      (PROG (I)
	    (SETQ I 0)
       LOOP (COND ((= I NUMACT) (RETURN I)))
	    (PROG (DATA)
		  (SETQ DATA (CDDR (NUMVAL (FRAMES I))))
	     LOOP1
		  (COND ((NULL DATA) (RETURN DATA)))
		  ((LAMBDA (D) (AND# (ATOM D) (RPLACD (CMARKERS D) NIL))) (CAR DATA))
		  (SETQ DATA (CDR DATA))
		  (GO LOOP1))
	    (SETQ I (ADD1 I))
	    (GO LOOP))))
    (PROGN (SETQ NUMCON N) (SETQ INCCON M))
    (ARRAY FRAMES 22 NUMCON)
    (ARRAY RFRAMES T NUMCON)
    (STORE (FRAMES 0) (MAKNUM (LIST (QUOTE *CFRAME) (SETQ *CNUM 0)) (QUOTE FIXNUM)))
    (STORE (RFRAMES 0) (CDR (NUMVAL (FRAMES 0))))
    (CSETQ CONTEXT (CSETQ GLOBAL (LIST (QUOTE *CONTEXT) (NUMVAL (FRAMES 0)))))
    (SETQ NUMACT 1)
    (PUTPROP (QUOTE ITEM) (SETQ *ITEMS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0)) (QUOTE *INDEX))
    (PUTPROP (QUOTE IF-NEEDED) (SETQ *IF-NEEDEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0)) (QUOTE *INDEX))
    (PUTPROP (QUOTE IF-ADDED) (SETQ *IF-ADDEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0)) (QUOTE *INDEX))
    (PUTPROP (QUOTE IF-REMOVED)
	     (SETQ *IF-REMOVEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0))
	     (QUOTE *INDEX)))
   (COND ((> K 0) (ARG 1)) (T 144))
   (COND ((> K 1) (ARG 2)) (T 12))))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP FETCH
 (LAMBDA N
  (PROG	(PATTERN CON)
	(PROGN (SETQ PATTERN (ARG 1)) (SETQ CON (COND ((GETCONTEXT 1 N)) ((ARG N)))))
	(RETURN
	 (CONS (LIST (QUOTE *POSSIBILITIES) PATTERN)
	       (CONS (QUOTE *IGNORE) (NCONC (FETCHI1 PATTERN CON) (FETCHM1 PATTERN *IF-NEEDEDS CON)))))))
EXPR)

(DEFPROP FETCHI
 (LAMBDA N
  (CONS	(LIST (QUOTE *POSSIBILITIES) (ARG 1))
	(CONS (QUOTE *IGNORE) (FETCHI1 (ARG 1) (COND ((GETCONTEXT 1 N)) ((ARG N)))))))
EXPR)

(DEFPROP FETCHM
 (LAMBDA N
  (COND ((> N 3) (TMA)))
  ((LAMBDA(CON)
    (CONS (LIST (QUOTE *POSSIBILITIES) (ARG 1))
	  (CONS	(QUOTE *IGNORE)
		(FETCHM1 (ARG 1) (COND ((< N 2) *IF-NEEDEDS) ((GET (ARG 2) (QUOTE *INDEX)))) CON))))
   (COND ((< N 3) (/, CONTEXT)) ((ARG 3)))))
EXPR)

(DEFPROP FETCHI1
 (LAMBDA(PATTERN CON)
  (PROG	(ALISTS)
	(RETURN
	 (MAPCAN (QUOTE
		  (LAMBDA(ITEM)
		   (COND
		    (($$$SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
		     (LIST (LIST (QUOTE *ITEM) ITEM (CAR ALISTS)))))))
		 (SEARCH *ITEMS PATTERN T (CDR CON))))))
EXPR)

(DEFPROP FETCHM1
 (LAMBDA(PATTERN INDEX CON)
  (MAPCAN (QUOTE
	   (LAMBDA(METHOD)
	    ((LAMBDA(MRESULT)
	      (COND (MRESULT (LIST (CONS (QUOTE *METHOD) (CONS METHOD (NCONC MRESULT (LIST PATTERN))))))))
	     (MATCH (PATTERN METHOD) PATTERN))))
	  (SEARCH INDEX PATTERN NIL (CDR CON))))
EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP REAL
 (LAMBDA N (AND# (REALITY (ARG 1) (COND ((GETCONTEXT 1 N)) ((ARG N)))) (ARG 1)))
EXPR)

(DEFPROP UNREAL
 (LAMBDA N (AND# (NOT (REALITY (ARG 1) (COND ((GETCONTEXT 1 N)) ((ARG N))))) (ARG 1)))
EXPR)

(DEFPROP PRESENT
 (LAMBDA N
  (PROG	(CON PAT CANDIDATES ALISTS)
	(PROGN (SETQ PAT (ARG 1))
	       (SETQ CON (COND ((GETCONTEXT 1 N)) ((ARG N))))
	       (SETQ CANDIDATES (SEARCH *ITEMS PAT T (CDR CON))))
   LOOP	(COND ((NULL CANDIDATES) (RETURN NIL))
	      ((SETQ ALISTS (MATCH PAT (ITEM (CAR CANDIDATES))))
	       (MAPC (QUOTE (LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR)))) (CAR ALISTS))
	       (RETURN (CAR CANDIDATES))))
	(SETQ CANDIDATES (CDR CANDIDATES))
	(GO LOOP)))
EXPR)

(DEFPROP ABSENT
 (LAMBDA N (UNREAL (DATUM (ARG 1)) (COND ((GETCONTEXT 1 N)) ((ARG N)))))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP SEARCH
 (LAMBDA(INDEX PATTERN ITEM CON)
  (MAPCAN (QUOTE (LAMBDA (THING) (COND ((REALITY1 (CDR (CMARKERS THING)) CON) (LIST THING)))))
	  (ISEARCH INDEX PATTERN ITEM)))
EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP REALITY
 (LAMBDA (DATUM CON) (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON)))
EXPR)

(DEFPROP REALITY1
 (LAMBDA(CMARKERS CFRAMES)
  (PROG	(CM CON)
	(SETQ CON CFRAMES)
   LOOP	(COND ((SETQ CM (MFINTERSECT))
	       (OR# (INVISIBLE (CADR CM) CON) (RETURN CM))
	       (PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP))
	      ((RETURN NIL)))))
EXPR)

(DEFPROP DATUM
 (LAMBDA(SKELETON)
  (PROG	(CANDIDATES)
	(SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
   LOOP	(COND ((NULL CANDIDATES) (RETURN (LIST SKELETON)))
	      ((EQUAL (ITEM (CAR CANDIDATES)) SKELETON) (RETURN (CAR CANDIDATES))))
	(SETQ CANDIDATES (CDR CANDIDATES))
	(GO LOOP)))
EXPR)

(DEFPROP ADD
 (LAMBDA N (REALIZE (DATUMIZE (ARG 1)) (COND ((GETCONTEXT 1 N)) ((ARG N)))))
EXPR)

(DEFPROP ADD
 ((THING "OPTIONAL" (CONTEXT CONTEXT)) (REALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
CEXPR)

(DEFPROP CREMOVE
 (LAMBDA N (UNREALIZE (DATUMIZE (ARG 1)) (COND ((GETCONTEXT 1 N)) ((ARG N)))))
EXPR)

(DEFPROP REMOVE
 ((THING "OPTIONAL" (CONTEXT CONTEXT)) (UNREALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
CEXPR)

(DEFPROP INSERT
 (LAMBDA N ((LAMBDA (D) (REVEAL D (COND ((GETCONTEXT 1 N)) ((ARG N)))) D) (DATUMIZE (ARG 1))))
EXPR)

(DEFPROP KILL
 (LAMBDA N ((LAMBDA (D) (HIDE D (COND ((GETCONTEXT 1 N)) ((ARG N)))) D) (DATUMIZE (ARG 1))))
EXPR)

(DEFPROP ACTUALIZE
 (LAMBDA N (REVEAL (ARG 1) (COND ((GETCONTEXT 1 N)) ((ARG N)))) (ARG 1))
EXPR)

(DEFPROP UNACTUALIZE
 (LAMBDA N (HIDE (ARG 1) (COND ((GETCONTEXT 1 N)) ((ARG N)))) (ARG 1))
EXPR)

(DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))

(DEFPROP REALIZE
 (LAMBDA N
  (PROG	(DATUM CON PAT)
	(PROGN (SETQ DATUM (ARG 1)) (SETQ CON (COND ((GETCONTEXT 1 N)) ((ARG N)))))
	(COND
	 ((AND# (REVEAL DATUM CON) ($$$SETQ PAT (ITEM DATUM)))
	  (CEVAL (QUOTE (CALLDEMONS (/@ . PAT) (/@ . *IF-ADDEDS) (/@ . CON))))))
	(RETURN DATUM)))
EXPR)

(DEFPROP REALIZE
 ((DATUM "OPTIONAL" (CONTEXT CONTEXT))
  "AUX"
  (PAT)
  (COND
   ((/@ AND (REVEAL (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
    (CALLDEMONS PAT (/@ . *IF-ADDEDS) CONTEXT)))
  DATUM)
CEXPR)

(DEFPROP UNREALIZE
 (LAMBDA N
  (PROG	(DATUM CON PAT)
	(PROGN (SETQ DATUM (ARG 1)) (SETQ CON (COND ((GETCONTEXT 1 N)) ((ARG N)))))
	(COND
	 ((AND# (HIDE DATUM CON) ($$$SETQ PAT (ITEM DATUM)))
	  (CEVAL (QUOTE (CALLDEMONS (/@ . PAT) (/@ . *IF-REMOVEDS) (/@ . CON))))))
	(RETURN DATUM)))
EXPR)

(DEFPROP UNREALIZE
 ((DATUM "OPTIONAL" (CONTEXT CONTEXT))
  "AUX"
  (PAT)
  (COND
   ((/@ AND (HIDE (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
    (CALLDEMONS PAT (/@ . *IF-REMOVEDS) CONTEXT)))
  DATUM)
CEXPR)

(DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))

(DEFPROP CALLDEMONS
 (LAMBDA(PAT INDEX CONTEXT)
  (CINTERRUPT (LIST (QUOTE RUNDAEMONS) PAT CONTEXT (SEARCH INDEX PAT NIL (CDR CONTEXT)))))
EXPR)

(DEFPROP RUNDAEMONS
 (((QUOTE PAT) (QUOTE CONTEXT) (QUOTE METS))
  (ALLOW T)
  (/: TLP)
  (COND (METS (INVOKE (NXTMET) PAT) (GO (QUOTE TLP)))))
CEXPR)

(DEFPROP NXTMET
 (LAMBDA (L) (PROG2 (SETQ L (CDR (VLOC (QUOTE METS)))) (CAAR L) (RPLACA L (CDAR L))))
FEXPR)

(DEFPROP REVEAL
 (LAMBDA(DATUM CON)
  (PROG	(CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE NUM)
	(PROGN (SETQ CMARKERS (ANALYZE DATUM))
	       (SETQ CFRAMES ($$$SETQ CON (CDR CON)))
	       (SETQ CM (ADDCFRAME ($$$SETQ CFRAME (CAR CON)) CMARKERS))
	       (SETQ CNUM (CADR CFRAME))
	       (SETQ STATUS (CADR CM)))
	(RPLACA (CDR CM) (QUOTE +))
	(COND (STATUS (RETURN NIL))
	      ((AND# PATTERN NEW (NULL (CDDR CMARKERS))) (INDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)))))
	(PROGN (SETQ CMARKERS (CDDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
   LOOP	(COND ((SETQ CM (MFINTERSECT))
	       (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
		      (COND
		       ((EQUAL CNUM NUM) (SETQ NEW NIL)
					 (RPLACA (CDR CM) (OR# (DELETE CNUM (CADR CM) 1) (QUOTE +))))))
		     ((SETQ STATUS T)))
	       (PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP))
	      (NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
	(RETURN (NOT STATUS))))
EXPR)

(DEFPROP HIDE
 (LAMBDA(DATUM CON)
  (PROG	(PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD CFRAME CM)
	(PROGN (SETQ CFRAMES ($$$SETQ CON (CDR CON))) (SETQ CMARKERS (ANALYZE DATUM)) (SETQ CNUM (CADAR CON)))
	(COND
	 ((SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES)) (CDR CMARKERS)))
	  (PROGN (SETQ STATUS (CADR CM)) (SETQ OLD T))
	  (COND	((CDDR CM) (RPLACA (CDR CM) NIL))
		((SETQ REM T)
		 (DELQ CM CMARKERS 1)
		 (AND# PATTERN
		       (NULL (CDR CMARKERS))
		       (UNINDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)) (EQ TYPE (QUOTE ITEM))))))))
	(SETQ CMARKERS (CDR CMARKERS))
   LOOP	(COND ((SETQ CM (MFINTERSECT))
	       (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
		      (COND (REM (SETQ REM (NOT (EQUAL CNUM NUM)))) ((OR# OLD ($$$SETQ OLD (EQUAL CNUM NUM))))))
		     ((PROGN (SETQ REM NIL) (SETQ STATUS T)) (CANCEL CM CNUM)))
	       (PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	       (GO LOOP))
	      (REM (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1)))
	      ((AND# STATUS (NOT OLD)) (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
	(RETURN STATUS)))
EXPR)

(DEFPROP ADDCFRAME
 (LAMBDA(CFRAME CMARKERS)
  (PROG	(N)
	(SETQ N (CADR CFRAME))
   LOOP	(COND ((OR# (NULL (CDR CMARKERS)) (LESSP (CAADR CMARKERS) N))
	       (RPLACD CMARKERS (CONS (LIST N NIL) (CDR CMARKERS)))
	       (SETQ NEW T))
	      ((EQ N (CAADR CMARKERS)))
	      (T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)))
	(RETURN (CADR CMARKERS))))
EXPR)

(DEFPROP FINDCFRAME
 (LAMBDA(CFRAME CMARKERS)
  (PROG	(NF NM)
	(SETQ NF (CADR CFRAME))
   LOOP	(COND ((NULL CMARKERS) (RETURN NIL))
	      ((> NF (SETQ NM (CAAR CMARKERS))) (RETURN NIL))
	      ((> NM NF) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP))
	      ((RETURN (CAR CMARKERS))))))
EXPR)

(DEFPROP CANCEL
 (LAMBDA (CM NUM) (RPLACA (CDR CM) (MERGEN NUM (CADR CM))))
EXPR)

(DEFPROP MERGEN
 (LAMBDA (N NL) (COND ((ATOM NL) (LIST N)) ((> N (CAR NL)) (CONS N NL)) ((RPLACD NL (MERGEN N (CDR NL))))))
EXPR)

(DEFPROP MERGE
 (LAMBDA(NL1 NL2)
  (COND	((ATOM NL1) NL2)
	((ATOM NL2) NL1)
	((> (CAR NL1) (CAR NL2)) (CONS (CAR NL1) (MERGE (CDR NL1) NL2)))
	((> (CAR NL2) (CAR NL1)) (CONS (CAR NL2) (MERGE NL1 (CDR NL2))))
	((CONS (CAR NL1) (MERGE (CDR NL1) (CDR NL2))))))
EXPR)

(DEFPROP DPUTCF
 (LAMBDA(DATUM PROPERTY INDICATOR CFRAME)
  (PROG	(PATTERN TYPE CM TAIL NEW)
	(PROGN (SETQ TAIL (ANALYZE DATUM)) (SETQ CM (ADDCFRAME CFRAME TAIL)))
	(COND
	 (NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))
	      (AND# PATTERN (NULL (CDDR TAIL)) (INDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX))))))
	(RETURN (DPUT1 CM PROPERTY INDICATOR))))
EXPR)

(DEFPROP DGETCF
 (LAMBDA (DATUM INDICATOR CFRAME) (ASSOC INDICATOR (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))))
EXPR)

(DEFPROP DREMCF
 (LAMBDA(DATUM INDICATOR CFRAME)
  (PROG	(CMARKERS PATTERN TYPE CM PAIR)
	(PROGN (SETQ CMARKERS (ANALYZE DATUM)) (SETQ CM (FINDCFRAME CFRAME (CDR CMARKERS))))
	(COND
	 ((AND# CM ($$$SETQ PAIR (ASSOC INDICATOR (CDDR CM))))
	  (DELQ PAIR (CDR CM) 1)
	  (COND ((NOT (OR# (CADR CM) (CDDR CM))) (DELQ CM CMARKERS 1) (DELQ DATUM CFRAME 1)))
	  (COND
	   ((AND# PATTERN (NULL (CDR CMARKERS)))
	    (UNINDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)) (EQ TYPE (QUOTE ITEM)))))
	  (RETURN PAIR)))))
EXPR)

(DEFPROP DPUT
 (LAMBDA N (DPUTCF (ARG 1) (ARG 2) (ARG 3) (CADR (COND ((GETCONTEXT 3 N)) ((ARG N))))))
EXPR)

(DEFPROP DGET
 (LAMBDA N
  ((LAMBDA (CONTEXT) (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR CONTEXT) NIL))
   (COND ((GETCONTEXT 2 N)) ((ARG N)))))
EXPR)

(DEFPROP DREM
 (LAMBDA N (DREM1 (ARG 1) (ARG 2) (CDR (COND ((GETCONTEXT 2 N)) ((ARG N)))) NIL))
EXPR)

(DEFPROP DPUT+
 (LAMBDA N
  ((LAMBDA (CM) (COND (CM (DPUT1 CM (ARG 2) (ARG 3))) ((CERR ABSENT DATUM))))
   (REALITY (ARG 1) (COND ((GETCONTEXT 3 N)) ((ARG N))))))
EXPR)

(DEFPROP DGET+
 (LAMBDA N (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR (COND ((GETCONTEXT 2 N)) ((ARG N)))) T))
EXPR)

(DEFPROP DREM+
 (LAMBDA N (DREM1 (ARG 1) (ARG 2) (CDR (COND ((GETCONTEXT 2 N)) ((ARG N)))) T))
EXPR)

(DEFPROP DPUT1
 (LAMBDA(CM PROPERTY INDICATOR)
  (PROG	(PAIR)
	(COND ((SETQ PAIR (ASSOC INDICATOR (CDDR CM)))
	       (OR (CDR PAIR) (RPLACD (CDR PAIR) (NCONS NIL)))
	       (RPLACA (CDR PAIR) PROPERTY))
	      ((RPLACD (CDR CM) (CONS (SETQ PAIR (LIST INDICATOR PROPERTY)) (CDDR CM)))))
	(RETURN PAIR)))
EXPR)

(DEFPROP DGET1
 (LAMBDA(CMARKERS INDICATOR CFRAMES SIGN)
  (PROG	(PAIR CM CON)
	(SETQ CON CFRAMES)
   LOOP	(COND ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
	      ((AND# SIGN (INVISIBLE (CADR CM) CON)))
	      ((SETQ PAIR (ASSOC INDICATOR (CDDR CM))) (RETURN PAIR)))
	(PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	(GO LOOP)))
EXPR)

(DEFPROP DREM1
 (LAMBDA(DATUM INDICATOR CFRAMES SIGN)
  (PROG	(PAIR CMARKERS TAIL PATTERN TYPE CM CON)
	(PROGN (SETQ CON CFRAMES) (SETQ CMARKERS (CDR ($$$SETQ TAIL (ANALYZE DATUM)))))
   LOOP	(COND ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
	      ((AND# SIGN (INVISIBLE (CADR CM) CON)))
	      ((SETQ PAIR (ASSOC INDICATOR (CDDR CM)))
	       (DELQ PAIR (CDR CM) NIL)
	       (COND ((NOT (OR# (CADR CM) (CDDR CM))) (DELQ CM TAIL NIL) (DELQ DATUM (CAR CFRAMES) NIL)))
	       (COND
		((AND# PATTERN (NULL (CDR TAIL)))
		 (UNINDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)) (EQ TYPE (QUOTE ITEM)))))
	       (RETURN PAIR)))
	(PROGN (SETQ CMARKERS (CDR CMARKERS)) (SETQ CFRAMES (CDR CFRAMES)))
	(GO LOOP)))
EXPR)

(DEFPROP MENTIONERS
 (LAMBDA N
  (PROG	(CFRAMES CMARKERS MENTIONERS SIGN CM CON)
	(COND ((< N 1) (TFA)))
	(PROGN (SETQ CFRAMES (CDR (COND ((< N 3) (/, CONTEXT)) ((= N 3) (ARG 3)) ((TMA)))))
	       (SETQ SIGN (COND ((> N 1) (ARG 2))))
	       (SETQ CMARKERS (CDR (CMARKERS (ARG 1))))
	       (SETQ CON CFRAMES))
   LOOP	(COND
	 ((SETQ CM (MFINTERSECT))
	  (OR# (AND# SIGN (INVISIBLE (CADR CM) CON)) ($$$SETQ MENTIONERS (CONS (CAR CFRAMES) MENTIONERS)))
	  (PROGN (SETQ CFRAMES (CDR CFRAMES)) (SETQ CMARKERS (CDR CMARKERS)))
	  (GO LOOP)))
	(RETURN (REVERSE MENTIONERS))))
EXPR)

(DECLARE (UNSPECIAL DATUM))

(DEFPROP C-MARKER
 (LAMBDA (DATUM CFRAME) (FINDCFRAME CFRAME (CDR (CMARKERS DATUM))))
EXPR)

(DECLARE (SPECIAL DATUM))

(DEFPROP MFINTERSECT
 (LAMBDA NIL
  (PROG	(NM NF CM)
   ADVANCE
	(COND ((AND# CMARKERS CFRAMES)
	       (PROGN (SETQ NF (CADAR CFRAMES)) (SETQ CM (CAR CMARKERS)) (SETQ NM (CAR CM))))
	      ((RETURN NIL)))
   TEST	(COND ((> NF NM) (OR# ($$$SETQ CFRAMES (CDR CFRAMES)) (RETURN NIL)) (SETQ NF (CADAR CFRAMES)) (GO TEST))
	      ((> NM NF) (OR# ($$$SETQ CMARKERS (CDR CMARKERS)) (RETURN NIL))
			 (PROGN (SETQ CM (CAR CMARKERS)) (SETQ NM (CAR CM)))
			 (GO TEST))
	      ((RETURN CM)))))
EXPR)

(DECLARE (UNSPECIAL CMARKERS))

(DEFPROP INVISIBLE
 (LAMBDA(CNUMS CFRAMES)
  (AND#	(NOT (EQ CNUMS (QUOTE +)))
	(OR# (NULL CNUMS)
	     (PROG (NC NF)
		   ($$$SETQ NC (CAR CNUMS))
	      LOOP (COND (CFRAMES ($$$SETQ NF (CADAR CFRAMES) CFRAMES (CDR CFRAMES))) ((RETURN NIL)))
	      TEST (COND ((> NF NC) (GO LOOP))
			 ((> NC NF) (OR# ($$$SETQ CNUMS (CDR CNUMS)) (RETURN NIL))
				    ($$$SETQ NC (CAR CNUMS))
				    (GO TEST))
			 ((RETURN NC)))))))
EXPR)

(DECLARE (UNSPECIAL CFRAMES))

(DEFPROP GETCONTEXT
 (LAMBDA (K N) (COND ((< N K) (TFA)) ((= N K) (/, CONTEXT)) ((= N (SETQ K (ADD1 K))) NIL) ((TMA))))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP ISEARCH
 (LAMBDA (INDEX PATTERN ITEM) (APPLY# (FUNCTION APPEND) (CDR (ISEARCH1 INDEX PATTERN ITEM))))
EXPR)

(DEFPROP ISEARCH1
 (LAMBDA(INDEX PATTERN ITEM)
  (PROG	(ASCAR ASCDR)
	(COND ((NULL INDEX) (RETURN (LIST 0)))
	      ((EQ (CAR INDEX) (QUOTE *LIST)) (RETURN (CONS (CADDR INDEX) (LIST (CDDDR INDEX)))))
	      ((EQ (CAR INDEX) (QUOTE *INDEX)))
	      (T (BREAK1 NIL T (QUOTE BAD-STRUCTURE-INDEX--ISEARCH) NIL NIL)))
	(RETURN
	 (COND ((OR# (ZEROP (CAR ($$$SETQ ASCAR (ASEARCH (CADDR INDEX) (CAR PATTERN) ITEM))))
		     (NULL (CDR PATTERN))
		     (> (CAR ($$$SETQ ASCDR (ASEARCH (CDDDR INDEX) (CDR PATTERN) ITEM))) (CAR ASCAR)))
		ASCAR)
	       (ASCDR)))))
EXPR)

(DEFPROP ASEARCH
 (LAMBDA(SUBINDEX ELEMENT ITEM)
  (PROG	(INDICATOR ASSOCIATION CLLIST VLIST)
	(COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) (QUOTE *VARIABLE)) (RETURN (LIST 10000))))
	(SETQ CLLIST
	      (COND ((EQ INDICATOR (QUOTE *STRUCTURE)) (ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM))
		    ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
		     (CONS (CADR ASSOCIATION) (LIST (CDDR ASSOCIATION))))
		    ((LIST 0))))
	(COND
	 ((AND#	(NOT ITEM)
		($$$SETQ ASSOCIATION (ASSOC (QUOTE *VARIABLE) (CDR SUBINDEX)))
		($$$SETQ VLIST (CDDR ASSOCIATION)))
	  (RPLACA CLLIST (+ (CAR CLLIST) (CADR ASSOCIATION)))
	  (RPLACD CLLIST (CONS VLIST (CDR CLLIST)))))
	(RETURN CLLIST)))
EXPR)

(DEFPROP ASSQ1
 (LAMBDA (IND ALIST) (COND ((NUMBERP IND) (ASSOC# IND ALIST)) ((ASSOC IND ALIST))))
EXPR)

(DECLARE (SPECIAL THING PFORM INDEX))

(DEFPROP INDEX
 (LAMBDA(THING PATTERN INDEX)
  (PROG	(NUM THINGS PFORM)
	(COND ((NULL INDEX) (BREAK1 NIL T (QUOTE BAD-INDEX--INDEX) NIL NIL))
	      ((EQ (CAR INDEX) (QUOTE *LIST))
	       (COND ((EQUAL (SETQ NUM (ADD1 (CADDR INDEX))) *INDEXTHRESHOLD)
		      (RPLACA INDEX (QUOTE *INDEX))
		      (PROGN (SETQ THINGS (CDDDR INDEX)) (SETQ PFORM (CADR INDEX)))
		      (RPLACD (CDR INDEX) (LIST (LIST NIL) NIL))
		      (MAPC (/!" LAMBDA (THING) (INDEX THING (/@ . PFORM) INDEX)) THINGS))
		     (T (RPLACD (CDR INDEX) (CONS NUM (CONS THING (CDDDR INDEX)))) (RETURN THING))))
	      ((EQ (CAR INDEX) (QUOTE *INDEX)) (SETQ PFORM (CADR INDEX)))
	      ((BREAK1 NIL T (QUOTE BAD-INDEX--INDEX) NIL NIL)))
	(INDEX1 THING (CAR PATTERN) (CADDR INDEX) (QUOTE CAR) PFORM)
	(AND# (CDR PATTERN) (INDEX1 THING (CDR PATTERN) (CDDDR INDEX) (QUOTE CDR) PFORM))
	(RETURN THING)))
EXPR)

(DECLARE (UNSPECIAL PFORM INDEX))

(DEFPROP UNINDEX
 (LAMBDA(THING PATTERN INDEX ITEM)
  (COND	((NULL INDEX) (BREAK1 NIL T (QUOTE BAD-INDEX--UNINDEX) NIL NIL))
	((EQ (CAR INDEX) (QUOTE *LIST))
	 (RPLACD (CDR INDEX) (CONS (SUB1 (CADDR INDEX)) (DELTHING THING (CDDDR INDEX) ITEM)))
	 THING)
	((EQ (CAR INDEX) (QUOTE *INDEX))
	 (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
	 (AND# (CDR PATTERN) (UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM))
	 THING)
	((BREAK1 NIL T (QUOTE BAD-INDEX--UNINDEX) NIL NIL))))
EXPR)

(DECLARE (UNSPECIAL THING))

(DEFPROP INDEX1
 (LAMBDA(THING ELEMENT SUBINDEX POS PFORM)
  (PROG	(INDICATOR ASSOCIATION)
	(COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) (QUOTE *STRUCTURE))
	       (COND ((NULL (CAR SUBINDEX)) (RPLACA SUBINDEX (LIST (QUOTE *LIST) (LIST POS PFORM) 0))))
	       (INDEX THING ELEMENT (CAR SUBINDEX)))
	      ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
	       (RPLACD ASSOCIATION (CONS (ADD1 (CADR ASSOCIATION)) (CONS THING (CDDR ASSOCIATION)))))
	      (T (RPLACD SUBINDEX (CONS (LIST INDICATOR 1 THING) (CDR SUBINDEX)))))))
EXPR)

(DEFPROP UNINDEX1
 (LAMBDA(THING ELEMENT SUBINDEX ITEM)
  (PROG	(ASSOCIATION INDICATOR NUM)
	(SETQ INDICATOR (ATOMIZE ELEMENT))
	(COND ((EQ INDICATOR (QUOTE *STRUCTURE)) (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM))
	      ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
	       (COND ((ZEROP (SETQ NUM (SUB1 (CADR ASSOCIATION)))) (DELQ ASSOCIATION SUBINDEX NIL))
		     (T (RPLACD ASSOCIATION (CONS NUM (DELTHING THING (CDDR ASSOCIATION) ITEM)))))))))
EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP ANALYZE
 (LAMBDA(X)
  (COND	((NULL X) (CERR MEANINGLESS DATUM -- ANALYZE))
	((ATOM X) (ANALYZE (GET X (QUOTE DATUM))))
	((EQ (CAR X) (QUOTE *CLOSURE)) (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X)))
	((EQ (CAR X) (QUOTE *OBJECT)) (PROGN (SETQ PATTERN NIL) (SETQ TYPE (QUOTE OBJECT))) (CDR X))
	((ATOM (SETQ TYPE (CAR X))) (SETQ PATTERN (CADDR X)) (AND# (CADR X) ($$$SETQ DATUM (CADR X))) (CDDDR X))
	(T (PROGN (SETQ PATTERN (CAR X)) (SETQ TYPE (QUOTE ITEM))) X)))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP CMARKERS
 (LAMBDA(DATUM)
  (COND	((NULL DATUM) (CERR MEANINGLESS DATUM -- CMARKERS))
	((ATOM DATUM) (CMARKERS (GET DATUM (QUOTE DATUM))))
	((EQ (CAR DATUM) (QUOTE *CLOSURE)) (CDDR DATUM))
	((EQ (CAR DATUM) (QUOTE *OBJECT)) (CDR DATUM))
	((ATOM (CAR DATUM)) (CDDDR DATUM))
	(DATUM)))
EXPR)

(DEFPROP PATTERN
 (LAMBDA(DATUM)
  (COND	((NULL DATUM) (CERR MEANINGLESS DATUM -- PATTERN))
	((ATOM DATUM) (PATTERN (GET DATUM (QUOTE DATUM))))
	((EQ (CAR DATUM) (QUOTE *CLOSURE)) (PATTERN (CADR DATUM)))
	((ATOM (CAR DATUM)) (CADDR DATUM))
	((CAR DATUM))))
EXPR)

(DEFPROP DELTHING
 (LAMBDA (THING LIST ITEM) (COND (ITEM (DELITEM (ITEM THING) LIST)) ((DELQ THING LIST T))))
EXPR)

(DEFPROP DELITEM
 (LAMBDA(EXP LIST)
  (COND	((NULL LIST) NIL)
	((EQUAL EXP (ITEM (CAR LIST))) (CDR LIST))
	(T (RPLACD LIST (DELITEM EXP (CDR LIST))))))
EXPR)

(DEFPROP MEMCAR
 (LAMBDA (EXP LIST) (COND ((NULL LIST) NIL) ((EQUAL EXP (ITEM (CAR LIST))) LIST) (T (MEMCAR EXP (CDR LIST)))))
EXPR)

(DEFPROP FIRSTCAR<
 (LAMBDA(N LIST)
  (PROG	NIL
   LOOP	(COND ((NULL LIST) (RETURN NIL))
	      ((< (CAAR LIST) N) (RETURN LIST))
	      (T (SETQ LIST (CDR LIST)) (GO LOOP)))))
EXPR)

(DEFPROP ITEM
 (LAMBDA(DATUM)
  (COND	((NULL DATUM) (CERR MEANINGLESS DATUM))
	((ATOM DATUM) (ITEM (GET DATUM (QUOTE DATUM))))
	(((LAMBDA (PAT) (AND# (NOT (ATOM PAT)) PAT)) (CAR DATUM)))))
EXPR)

(DEFPROP DATUMIZE
 (LAMBDA (THING) (COND ((ATOM THING) THING) ((DATUM THING))))
EXPR)

(DEFPROP ATOMIZE
 (LAMBDA(ELEMENT)
  (COND ((ATOM ELEMENT) ELEMENT) ((ACTOR (CAR ELEMENT)) (QUOTE *VARIABLE)) (T (QUOTE *STRUCTURE))))
EXPR)

(DEFPROP PUSH-CONTEXT
 (LAMBDA N (CONS (QUOTE *CONTEXT) (CONS (CFRAME) (CDR (COND ((GETCONTEXT 0 N)) ((ARG N)))))))
EXPR)

(DEFPROP POP-CONTEXT
 (LAMBDA N (CONS (QUOTE *CONTEXT) (CDDR (COND ((GETCONTEXT 0 N)) ((ARG N))))))
EXPR)

(DECLARE (UNSPECIAL CFRAMES))

(DEFPROP NEW-CONTEXT
 (LAMBDA (CFRAMES) (COND ((ORDERED CFRAMES) (CONS (QUOTE *CONTEXT) CFRAMES)) ((CERR UNORDERED CONTEXT))))
EXPR)

(DECLARE (SPECIAL CFRAMES))

(DEFPROP SPLICE
 (LAMBDA(CONTEXT)
  (RPLACD (CDR CONTEXT) (CONS (CFRAME (NEWCNUM (CADR (CADDR CONTEXT)) (CADADR CONTEXT))) (CDDR CONTEXT)))
  CONTEXT)
EXPR)

(DECLARE (SPECIAL EXPR))

(DEFPROP IN-CONTEXT
 (LAMBDA (CONTEXT EXPR) (CEVAL (QUOTE ((CLAMBDA (CONTEXT) (CEVAL (/@ . EXPR))) (/@ . CONTEXT)))))
EXPR)

(DEFPROP IN-CONTEXT
 ((CONTEXT EXPR) (CEVAL EXPR))
CEXPR)

(DECLARE (UNSPECIAL EXPR))

(DEFPROP PATH
 (LAMBDA (C) (CONS (QUOTE *CONTEXT) (MAPCAR (QUOTE CADR) (CDR C))))
EXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP FINALIZE
 (LAMBDA(CON)
  (PROG	(CF CF2 DATA CN CN2 DATUM PATTERN TYPE TAIL NEW OLD CM CM2 PAIR2 SW)
	(SETQ CON (CDR CON))
	(SETQ CF (CAR CON))
	(SETQ DATA (CDR CF))
	(SETQ CN (CAR DATA))
	(SETQ CF2 (CADR CON))
	(SETQ CN2 (CADR CF2))
   LOOP	(COND ((NULL (SETQ DATA (CDR DATA))) (RETURN (CONS (QUOTE *CONTEXT) (CDR CON)))))
	(SETQ DATUM (CAR DATA))
	(SETQ TAIL (ANALYZE DATUM))
	(COND ((SETQ CM (FINDCFRAME CF (CDR TAIL)))
	       (SETQ CM2 (ADDCFRAME CF2 TAIL))
	       (SETQ SW (CADR CM))
	       (SETQ OLD (NOT NEW)))
	      ((SETQ CM2 (SETQ OLD (FINDCFRAME CF2 (CDR TAIL))))))
	(COND
	 (CM
	  (MAPC	(FUNCTION
		 (LAMBDA(PAIR)
		  (COND	((SETQ PAIR2 (ASSOC (CAR PAIR) CM2)) (RPLACD PAIR2 (CDR PAIR)))
			((RPLACD (CDR CM2) (CONS PAIR (CDDR CM2)))))))
		(CDDR CM))))
	(COND (SW (RPLACA (CDR CM2) (OR# (MERGE (CADR CM) (CADR CM2)) (QUOTE +))))
	      (T (COND ((AND CM2 (NOT (ATOM (CADR CM2))) (MEMBER# CN (CADR CM2))) (HIDE DATUM CON) (GO LOOP)))
		 (MAPC (FUNCTION
			(LAMBDA(CM3)
			 (COND
			  ((AND (NOT (ATOM (CADR CM3))) (MEMBER# CN (CADR CM3)))
			   (SETQ NEW T)
			   (OR# OLD (SETQ OLD (MEMBER# CN2 (CADR CM3))))
			   (RPLACA (CDR CM3) (MERGEN CN2 (CADR CM3)))))))
		       (FIRSTCAR< CN2 (CDR TAIL)))))
	(AND# NEW (NOT OLD) (RPLACD (CDR CF2) (CONS DATUM (CDDR CF2))))
	(GO LOOP)))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP CFRAME
 (LAMBDA K
  ((LAMBDA(NFRAME)
    (COND ((AND# (= NUMACT NUMCON) (PROG2 (GC) (= (GCCON) NUMCON))) (CERR TOO MANY CONTEXT-FRAMES)))
    (STORE (FRAMES NUMACT) (MAKNUM NFRAME (QUOTE FIXNUM)))
    (STORE (RFRAMES NUMACT) (CDR NFRAME))
    (SETQ NUMACT (ADD1 NUMACT))
    NFRAME)
   (LIST (QUOTE *CFRAME) (COND ((ZEROP K) (SETQ *CNUM (PLUS INCCON *CNUM))) (T (ARG 1))))))
EXPR)

(DEFPROP ORDERED
 (LAMBDA(CLIST)
  (OR# (NULL CLIST)
       (PROG NIL
	LOOP (COND
	      ((CDR CLIST) (OR# (< (CADADR CLIST) (CADAR CLIST)) (RETURN NIL))
			   ($$$SETQ CLIST (CDR CLIST))
			   (GO LOOP)))
	     (RETURN T))))
EXPR)

(DEFPROP NEWCNUM
 (LAMBDA(LOW HIGH)
  (PROG	(N INC INUSE)
	(PROGN (SETQ N (*QUO (PLUS LOW HIGH) 2)) (SETQ INUSE (CNUMSINUSE LOW HIGH)) (SETQ INC 1))
   LOOP	(COND ((GREATERP HIGH N LOW)
	       (COND ((MEMBER# N INUSE)
		      (PROGN (SETQ N (PLUS N INC)) (SETQ INC (DIFFERENCE 0 (ADD1 INC))))
		      (GO LOOP))
		     ((RETURN N))))
	      ((CERR NO NEW CNUM BETWEEN (* LOW) AND# (* HIGH))))))
EXPR)

(DEFPROP CNUMSINUSE
 (LAMBDA(LOW HIGH)
  (PROG	(I NUMS J N)
	(PROGN (SETQ I 0) (SETQ J (SUB1 NUMACT)))
   LOOP	(COND ((> I J) (RETURN NUMS))
	      ((OR# (> LOW ($$$SETQ N (CAR (RFRAMES I)))) (> N HIGH)))
	      ((SETQ NUMS (CONS N NUMS))))
	(SETQ I (ADD1 I))
	(GO LOOP)))
EXPR)

(DEFPROP *GCCON
 (LAMBDA NIL
  (PROG	(M N)
	(PROGN (SETQ N 0) (SETQ M NUMACT))
   NGCLP
	(COND ((= M N) (RETURN N)) ((EQ (CDR (NUMVAL (FRAMES N))) (RFRAMES N)) (SETQ N (ADD1 N)) (GO NGCLP)))
	(FLUSH (RFRAMES N))
	(STORE (RFRAMES N) 0)
   MGCLP
	(SETQ M (SUB1 M))
	(COND ((= M N) (RETURN N)) ((EQ (CDR (NUMVAL (FRAMES M))) (RFRAMES M)) (GO EXCH)))
	(FLUSH (RFRAMES M))
	(STORE (RFRAMES M) 0)
	(GO MGCLP)
   EXCH	(STORE (FRAMES N) (FRAMES M))
	(STORE (RFRAMES N) (RFRAMES M))
	(STORE (RFRAMES M) 0)
	(GO NGCLP)))
EXPR)

(DEFPROP GCCON
 (LAMBDA (L) (SETQ L (SETQ NUMACT (*GCCON))) L)
FEXPR)

(DECLARE (SPECIAL PATTERN))

(DEFPROP FLUSH
 (LAMBDA(CFRAME)
  (PROG	(DATUM THINGS N PATTERN TYPE CMARKERS)
	(PROGN (SETQ THINGS (CDR CFRAME)) (SETQ N (CAR CFRAME)))
   LOOP	(COND ((NULL THINGS) (RETURN NIL)))
	(COND
	 ((AND#	(REMCFRAME N ($$$SETQ CMARKERS (ANALYZE ($$$SETQ DATUM (CAR THINGS)))))
		PATTERN
		(NULL (CDR CMARKERS)))
	  (UNINDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)) (EQ TYPE (QUOTE ITEM)))))
	(SETQ THINGS (CDR THINGS))
	(GO LOOP)))
EXPR)

(DECLARE (UNSPECIAL PATTERN))

(DEFPROP REMCFRAME
 (LAMBDA(N CMARKERS)
  (PROG	(M CM REMSW)
   LOOP1
	(COND ((NULL (CDR CMARKERS)) (RETURN NIL))
	      ((= N (SETQ M (CAADR CMARKERS)))
	       (COND ((PROG1 (CADADR CMARKERS) (RPLACD CMARKERS (CDDR CMARKERS))) (RETURN T)))
	       (SETQ REMSW T))
	      ((> N M) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP1)))
   LOOP2
	(SETQ CMARKERS (CDR CMARKERS))
	(COND ((NULL CMARKERS) (RETURN REMSW))
	      ((ATOM (CADR (SETQ CM (CAR CMARKERS))))
	       (AND# (MEMBER# N (CADR CM)) (RPLACA (CDR CM) (OR# (DELETE N (CADR CM) 1) (QUOTE +))))))
	(GO LOOP2)))
EXPR)

(DEFPROP /!"
 (LAMBDA (L) (/!"1 L))
FEXPR)

(DEFPROP /!"
 CP-!"
CPRINT)

(DEFPROP /!"1
 (LAMBDA(L)
  (COND	((ATOM L) L)
	((EQ (CAR L) (QUOTE /@)) (EVAL (CDR L)))
	((EQ (CAR L) (QUOTE /,)) (IVAL (CADR L) (QUOTE *TOP)))
	((ATOM (CAR L)) (CONS (CAR L) (/!"1 (CDR L))))
	((EQ (CAAR L) (QUOTE /!@)) (APPEND (EVAL (CDAR L)) (/!"1 (CDR L))))
	(T (CONS (/!"1 (CAR L)) (/!"1 (CDR L))))))
EXPR)

(DEFPROP KTH
 (LAMBDA (LST NUM) (CAR (NTH LST NUM)))
EXPR)

(DECLARE (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
	 (*FEXPR CERR INSTANCE PROPOSE /,)
	 (*LEXPR CSET VFRAME ACCESS CONTROL))

(DEFPROP ALINK
 (LAMBDA (L) (LIST (QUOTE CDADR) (CADR L)))
MACRO)

(DEFPROP CLINK
 (LAMBDA (L) (LIST (QUOTE CDDDR) (CADR L)))
MACRO)

(DEFPROP TRY-NEXT
 ((POSSIBILITIES "OPTIONAL" (NOMORE NIL) (MESSAGE NIL))
  "AUX"
  (POS)
  (/: TRY-NEXT)
  (GO (NEXT))
  (/: EXIT)
  (RETURN (CEVAL NOMORE (ACCESS)))
  (/: RETURN)
  (RETURN POS)
  (/: *METHOD)
  (METGO)
  (/: *GENERATOR)
  (GENGO)
  (/: *AU-REVOIR)
  (REGO)
  (/: *BLOCK)
  (TBLOCK))
CEXPR)

(DEFPROP NEXT
 (LAMBDA(L)
  (SETQ L (/, POSSIBILITIES))
  (COND ((OR# (ATOM L) (NOT (EQ (CAAR L) (QUOTE *POSSIBILITIES)))) (CERR BAD POSSIBILITIES LIST)))
  (PROG	(P)
	(COND ((NULL (CDR L)) (RETURN (QUOTE EXIT))))
	(UNBLOCK (CDR L))
   TN	(COND ((NULL (CDDR L)) (RETURN (QUOTE EXIT))))
	(RPLACD L (CDDR L))
	(COND ((EQ (SETQ P (CADR L)) (QUOTE *IGNORE)) (GO TN))
	      ((ATOM P) (CSET (QUOTE POS) P) (RETURN (QUOTE RETURN)))
	      ((EQ (CAR P) (QUOTE *ITEM)) (SETUP (CADDR P)) (CSET (QUOTE POS) (CADR P)) (RETURN (QUOTE RETURN)))
	      ((EQ (CAR P) (QUOTE *NOTE)) (SETUP (CADR P)) (CSET (QUOTE POS) P) (RETURN (QUOTE RETURN)))
	      ((MEMQ# (CAR P) (QUOTE (*METHOD *GENERATOR *AU-REVOIR *BLOCK))) (RETURN (CAR P)))
	      (T (CSET (QUOTE POS) P) (RETURN (QUOTE RETURN))))))
FEXPR)

(DEFPROP SETUP
 (LAMBDA (ALIST) (SETQ TEM (ACCESS)) (MAPC (QUOTE (LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR) TEM))) ALIST))
EXPR)

(DEFPROP GENGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
	 (SETQ BVARS (LIST (LIST (QUOTE NEXT) TEM)))
	 (SETQ CLINK (FR (TAG (QUOTE TRY-NEXT))))
	 (SETQ ALINK (ALINK CLINK))
	 (SETQ TEM1 (CADAR TEM))
	 (SETQ FRAME* NIL))
  (RPLACA TEM (LIST (QUOTE *BLOCK)))
  (DISPATCH TEM1 (QUOTE POPJ) NIL (QUOTE *TOP)))
EXPR)

(DEFPROP GENGO
 GENGO
CINT)

(DEFPROP METGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
	 (SETQ TEM1 (CADAR TEM))
	 (SETQ BVARS
	       (NCONC (LIST (LIST (QUOTE NEXT) TEM)
			    (LIST (QUOTE *BODY) (TEXT TEM1))
			    (LIST (QUOTE *CALLPAT) (CADDDR (CDAR TEM)))
			    (LIST (QUOTE *METHPAT) (PATTERN TEM1))
			    (LIST (QUOTE *CALLALIST) (CADDDR (CAR TEM)))
			    (LIST (QUOTE *METHALIST) (CADDAR TEM)))
		      (CADDAR TEM)))
	 (SETQ EXP (LIST TEM1 (CADDDR (CDAR TEM))))
	 (SETQ FRAME* NIL)
	 (SETQ CLINK (FR (TAG (QUOTE TRY-NEXT))))
	 (SETQ ALINK (ALINK CLINK)))
  (CLOSE)
  (RPLACA TEM (LIST (QUOTE *BLOCK)))
  (QUOTE AUXB))
EXPR)

(DEFPROP METGO
 METGO
CINT)

(DEFPROP REGO
 (LAMBDA NIL
  (PROGN (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
	 (SETQ VAL (IVAL (QUOTE MESSAGE) ALINK))
	 (SETQ FRAME* (CADAR TEM)))
  (SETCONTROL (VFRAME (QUOTE NEXT) (CAR TEM)) (TAG (QUOTE TRY-NEXT)))
  (CSET (QUOTE NEXT) TEM (CAR TEM))
  (RPLACA TEM (LIST (QUOTE *BLOCK)))
  (RESTORE))
EXPR)

(DEFPROP REGO
 REGO
CINT)

(DEFPROP TBLOCK
 (NIL (NCONC (CADR POSSIBILITIES) (TAG (QUOTE TRY-NEXT)))
      (ALLOW NIL)
      (COND ((/@ . READY) (CONTINUE (/@ PROG2 (ALLOW T) (CAR READY) (SETQ READY (CDR READY))))))
      (ALLOW T)
      (LISTEN (QUOTE ALL-BLOCKED-UP)))
CEXPR)

(DEFPROP UNBLOCK
 (LAMBDA(L)
  (COND
   ((EQ (CAAR L) (QUOTE *BLOCK))
    (NCONC (GET (QUOTE READY) (QUOTE VALUE)) (CDAR L))
    (RPLACA L (QUOTE *IGNORE)))))
EXPR)

(DEFPROP NOTE
 (LAMBDA N
  (COND	((= N 0) ((LAMBDA (P) (COND (P (ENTER P)))) (INSTANCE)) 0)
	(T
	 (PROG (NEXT M)
	       (PROGN (SETQ M 0) (SETQ NEXT (CDR (VLOC (QUOTE NEXT)))))
	  LP   (COND ((> (SETQ M (ADD1 M)) N) (RETURN N)))
	       (RPLACD (CAR NEXT) (CONS (ARG M) (CDAR NEXT)))
	       (RPLACA NEXT (CDAR NEXT))
	       (GO LP)))))
EXPR)

(DEFPROP ADIEU
 (("REST" L) (PROPOSE) (DISMISS (VFRAME (QUOTE NEXT))))
CEXPR)

(DEFPROP AU-REVOIR
 (("REST" L) (PROPOSE) (ENTER (CONS (QUOTE *AU-REVOIR) (CDR (CONTROL)))) (DISMISS (VFRAME (QUOTE NEXT))))
CEXPR)

(DEFPROP ENTER
 (LAMBDA(X)
  (SETQ TEM (CDR (VLOC (QUOTE NEXT))))
  (RPLACD (CAR TEM) (CONS X (CDAR TEM)))
  (RPLACA TEM (CDAR TEM)))
EXPR)

(DEFPROP PROPOSE
 (LAMBDA(L)
  (SETQ L (CDR (VLOC (QUOTE NEXT))))
  (MAPC (QUOTE (LAMBDA (X) (RPLACD (CAR L) (CONS X (CDAR L))) (RPLACA L (CDAR L)))) (/, L)))
FEXPR)

(DEFPROP INSTANCE
 (LAMBDA(L)
  (PROG	(NEXTF CALLA)
	(PROGN (SETQ NEXTF (FR (VFRAME (QUOTE NEXT))))
	       (SETQ CALLA (IVAL (QUOTE *CALLALIST) NEXTF))
	       (SETQ L
		     (MATCH (IVAL (QUOTE *CALLPAT) NEXTF)
			    (IVAL (QUOTE *METHPAT) NEXTF)
			    CALLA
			    (IVAL (QUOTE *METHALIST) NEXTF))))
	(COND (L (RETURN (LIST (QUOTE *NOTE) (CPY (CAR L))))))))
FEXPR)

(DEFPROP CPY
 (LAMBDA (L) (MAPCAR (QUOTE (LAMBDA (X) (LIST (CAR X) (CADR X)))) L))
EXPR)

(DEFPROP GET-POSSIBILITIES
 (LAMBDA NIL (IVAL (QUOTE POSSIBILITIES) (CLINK (FR (VFRAME (QUOTE NEXT))))))
FEXPR)

(DEFPROP SET-POSSIBILITIES
 (LAMBDA (LIST) (CSET (QUOTE POSSIBILITIES) LIST (CONTROL (VFRAME (QUOTE NEXT)))))
EXPR)

(DEFPROP GENERATE
 (((QUOTE FORM))
  "AUX"
  ((POSSIBILITIES (LIST (LIST (QUOTE *POSSIBILITIES) (/, FORM)) (LIST (QUOTE *GENERATOR) (/, FORM)))))
  (GENGO)
  (/: TRY-NEXT)
  POSSIBILITIES)
CEXPR)

(DECLARE (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND VALV)
	 (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
	 (*FEXPR CERR))

(DEFPROP MATCH
 (LAMBDA N
  ((LAMBDA(VARPAT DATAPAT)
    (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
	  (COND ((> N 2) (PROGN (SETQ MALIST1 (ARG 3)) (SETQ MALIST2 (ARG 4)) (SETQ NOBIND T))))
	  (PROGN (SETQ MALISTV1 (GET (QUOTE MALIST1) (QUOTE VALUE)))
		 (SETQ MALISTV2 (GET (QUOTE MALIST2) (QUOTE VALUE))))
	  (RETURN (COND ((MATCH1 VARPAT DATAPAT) (LIST MALIST1 MALIST2))))))
   (ARG 1)
   (ARG 2)))
EXPR)

(DECLARE (UNSPECIAL MALIST1 MALIST2))

(DEFPROP MATCH1
 (LAMBDA(VARPAT DATAPAT)
  (PROG	(ACTOR1 ACTOR2)
	(RETURN
	 (COND ((ATOM VARPAT) (MATCH2 DATAPAT VARPAT MALISTV2))
	       ((ATOM DATAPAT) (MATCH2 VARPAT DATAPAT MALISTV1))
	       ((EQ (SETQ ACTOR2 (CAR DATAPAT)) (QUOTE /!')))
	       ((MEMQ# ACTOR2 (QUOTE (/!< /!?))) (MATCH2 VARPAT (ACTORSUBST DATAPAT (CDR MALISTV2)) MALISTV1))
	       ((EQ (SETQ ACTOR1 (CAR VARPAT)) (QUOTE /!>)) (/!> (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
	       ((EQ ACTOR1 (QUOTE /!?)) (/!? (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T))
	       ((EQ ACTOR1 (QUOTE /!')) (MBINDR (CADR VARPAT) (CDDR VARPAT) DATAPAT MALISTV1))
	       ((EQ ACTOR1 (QUOTE /!<)) (/!< (CADR VARPAT) DATAPAT MALISTV1 MALISTV2))
	       ((EQ ACTOR1 (QUOTE /!/,)) (COMMA (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
	       ((EQ ACTOR1 (QUOTE /!;)) (/!; (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T))
	       ((EQ ACTOR2 (QUOTE /!>)) (/!? (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL))
	       ((EQ ACTOR2 (QUOTE /!;)) (/!; (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL))
	       ((EQ ACTOR2 (QUOTE /!/,)) (COMMA (CDR DATAPAT) VARPAT MALISTV2 MALISTV1))
	       ((MATCH1 (CAR VARPAT) (CAR DATAPAT)) (MATCH1 (CDR VARPAT) (CDR DATAPAT)))))))
EXPR)

(DECLARE (UNSPECIAL MALISTV2))

(DEFPROP COMMA
 (LAMBDA(VARSPEC DATAPAT MV1 MV2)
  ((LAMBDA(VAR VALSPEC)
    (COND (VALSPEC
	   ((LAMBDA (VAL) (COND ((MATCH2 DATAPAT VAL MV2) (MBINDV VAR VAL MV1))))
	    ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV1))))
	  (((LAMBDA(VAL)
	     (COND ((EQ VAL (QUOTE *UNASSIGNED)) (TRYASSIGN VAR DATAPAT (CDR MV1) MV2 (EQ MV1 MALISTV1) NIL))
		   ((MATCH2 DATAPAT VAL MV2))))
	    ((LAMBDA (MALIST) (/!/,1 VAR)) (CDR MV1))))))
   (CAR VARSPEC)
   (CDR VARSPEC)))
EXPR)

(DECLARE (UNSPECIAL MALISTV1))

(DEFPROP MATCH2
 (LAMBDA(VARPAT EXP MV)
  (COND	((ATOM VARPAT) (EQUAL VARPAT EXP))
	(((LAMBDA(ACTOR)
	   (COND ((MEMQ# ACTOR (QUOTE (/!? /!> /!'))) (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV))
		 ((EQ ACTOR (QUOTE /!/,))
		  ((LAMBDA(VAR VALSPEC)
		    (COND (VALSPEC
			   ((LAMBDA (VAL) (COND ((EQUAL VAL EXP) (MBINDV VAR EXP MV))))
			    ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV))))
			  (((LAMBDA(VAL)
			     (COND ((EQ VAL (QUOTE *UNASSIGNED)) (MSET VAR EXP (CDR MV))) ((EQUAL VAL EXP))))
			    ((LAMBDA (MALIST) (/!/,1 VAR)) (CDR MV))))))
		   (CADR VARPAT)
		   (CDDR VARPAT)))
		 ((EQ ACTOR (QUOTE /!;))
		  (PROG	(VAR VALV RS)
			(PROGN (SETQ VAR (CADR VARPAT)) (SETQ RS (CDDR VARPAT)))
			(RETURN
			 (COND ((SETQ VALV (ASSOC VAR (CDR MV)))
				(AND# (COND ((EQ ($$$SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))
					     (MSET VAR EXP (CDR MV)))
					    ((EQUAL VALV EXP)))
				      (SATISFY RS (CDR MV))))
			       ((CHECKVAL VAR) (AND# (EQUAL VALV EXP) (SATISFY RS (CDR MV))))
			       ((MBINDR VAR RS EXP MV))))))
		 ((EQ ACTOR (QUOTE /!<)) NIL)
		 ((ATOM EXP) NIL)
		 ((MATCH2 ACTOR (CAR EXP) MV) (MATCH2 (CDR VARPAT) (CDR EXP) MV))))
	  (CAR VARPAT)))))
EXPR)

(DEFPROP /!?
 (LAMBDA(VARSPEC PAT VALISTV PALISTV VARSALLOWED)
  ((LAMBDA(VAR RS VARS)
    (COND (VARS
	   (COND
	    ((OR# VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
	     (COND ((HASVARS VARS) (MBINDV VAR (QUOTE *UNASSIGNED) VALISTV))
		   ((OR# (NOT VAR) (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV)))))))
	  (T (MBINDR VAR RS PAT VALISTV))))
   (CAR VARSPEC)
   (CDR VARSPEC)
   (FINDVARS PAT PALISTV)))
EXPR)

(DEFPROP /!?
 CP-MATCH
CPRINT)

(DEFPROP /!>
 (LAMBDA(VARSPEC PAT VALISTV PALISTV)
  ((LAMBDA(VAR RS VARS)
    (COND (VARS
	   (COND ((HASVARS VARS) NIL) (T (OR# (NOT VAR) (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV)))))
	  (T (MBINDR VAR RS PAT VALISTV))))
   (CAR VARSPEC)
   (CDR VARSPEC)
   (FINDVARS PAT PALISTV)))
EXPR)

(DEFPROP /!>
 CP-MATCH
CPRINT)

(DEFPROP TRYASSIGN
 (LAMBDA N
  (PROG	(VARS VAR PAT MALIST PALISTV VARSALLOWED RS)
	(SETQ VARS (FINDVARS (ARG 2) (ARG 4)))
	(SETQ VAR (ARG 1))
	(SETQ PAT (ARG 2))
	(SETQ MALIST (ARG 3))
	(SETQ PALISTV (ARG 4))
	(SETQ VARSALLOWED (ARG 5))
	(SETQ RS (ARG 6))
	(COND (VARS
	       (COND
		((OR# VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
		 (COND ((HASVARS VARS))
		       (T
			((PROG (VAL) (MSET VAR VAL MALIST) (SATISFY RS MALIST))
			 (VARSUBST PAT (CDR PALISTV))))))))
	      (T (MSET VAR PAT MALIST) (SATISFY RS MALIST)))))
EXPR)

(DEFPROP /!<
 (LAMBDA(VAR PAT VALISTV PALISTV)
  ((LAMBDA(VARS)
    (COND (VARS (COND ((HASVARS VARS) (OR# (NOT VAR) (MBIND VAR (VARSUBST PAT (CDR PALISTV)) VALISTV)))))))
   (FINDVARS PAT PALISTV)))
EXPR)

(DEFPROP /!<
 CP-MATCH
CPRINT)

(DEFPROP /!;
 (LAMBDA(VARSPEC PAT VALISTV PALISTV MUSTBIND)
  (PROG	(VAR VALV RS)
	(PROGN (SETQ VAR (CAR VARSPEC)) (SETQ RS (CDR VARSPEC)))
	(RETURN
	 (COND ((SETQ VALV (ASSOC VAR (CDR VALISTV)))
		(COND ((EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))
		       (TRYASSIGN VAR PAT (CDR VALISTV) PALISTV MUSTBIND RS))
		      ((MATCH2 PAT VALV PALISTV) (SATISFY RS (CDR VALISTV)))))
	       ((CHECKVAL VAR) (AND# (MATCH2 PAT VALV PALISTV) (SATISFY RS (CDR VALISTV))))
	       (MUSTBIND (/!> VARSPEC PAT VALISTV PALISTV))
	       ((/!? VARSPEC PAT VALISTV PALISTV NIL))))))
EXPR)

(DEFPROP /!;
 CP-MATCH
CPRINT)

(DEFPROP CHECKVAL
 (LAMBDA(VAR)
  (COND	((SETQ VALV (VLOC VAR)) (NOT (EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))))
	((SETQ VALV (BOUNDP VAR)) (NOT (EQ (SETQ VALV (CDR VALV)) (QUOTE *UNASSIGNED))))))
EXPR)

(DECLARE (UNSPECIAL VALV))

(DEFPROP FINDVARS
 (LAMBDA(PAT MALISTV)
  (COND	((ATOM PAT) NIL)
	(((LAMBDA(CAR)
	   (COND ((EQ CAR (QUOTE /!/,))
		  ((LAMBDA(VAR VALSPEC)
		    (COND ((OR# (NULL VALSPEC) NOBIND) (GETSPEC (QUOTE /!/,) VAR (CDR MALISTV)))
			  ((MBINDV VAR ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MALISTV)) MALISTV)
			   (LIST (QUOTE NIL)))))
		   (CADR PAT)
		   (CDDR PAT)))
		 ((EQ CAR (QUOTE /!;))
		  ((LAMBDA(VAR MALIST)
		    (COND ((ASSIGNED? VAR) (LIST NIL))
			  ((OR# NOBIND (ASSOC VAR MALIST)) (GETSPEC (QUOTE /!;) VAR MALIST))
			  ((MBINDV VAR (QUOTE *UNASSIGNED) MALISTV) (LIST (QUOTE /!>)))))
		   (CADR PAT)
		   (CDR MALISTV)))
		 ((ACTOR CAR)
		  (COND	(NOBIND (GETSPEC CAR (CADR PAT) (CDR MALISTV)))
			((MBINDV (CADR PAT) (QUOTE *UNASSIGNED) MALISTV) (LIST CAR))))
		 ((NCONC (FINDVARS CAR MALISTV) (FINDVARS (CDR PAT) MALISTV)))))
	  (CAR PAT)))))
EXPR)

(DEFPROP HASMUSTASSIGNS
 (LAMBDA(VARS)
  (PROG	(V)
	(SETQ V VARS)
   LOOP	(COND ((NULL V) (RETURN V)))
	(AND# (MEMQ# (CAR V) (QUOTE (/!> /!'))) (RETURN T))
	(SETQ V (CDR V))
	(GO LOOP)))
EXPR)

(DEFPROP HASVARS
 (LAMBDA(VARS)
  (PROG	(V)
	(SETQ V VARS)
   LOOP	(COND ((NULL V) (RETURN V)))
	(AND# (CAR V) (RETURN T))
	(SETQ V (CDR V))
	(GO LOOP)))
EXPR)

(DEFPROP VARSUBST
 (LAMBDA(PAT MALIST)
  (COND	((ATOM PAT) PAT)
	((ACTOR (CAR PAT)) (ACTORSUBST PAT MALIST))
	((CONS (VARSUBST (CAR PAT) MALIST) (VARSUBST (CDR PAT) MALIST)))))
EXPR)

(DEFPROP ACTOR
 (LAMBDA (ATOM) (MEMQ# ATOM (QUOTE (/!> /!? /!' /!< /!/, /!;))))
EXPR)

(DEFPROP ACTORSUBST
 (LAMBDA(PAT MALIST)
  ((LAMBDA (VAR) ((LAMBDA (VAL) (COND ((EQ VAL (QUOTE *UNASSIGNED)) PAT) (VAL))) (/!/,1 VAR))) (CADR PAT)))
EXPR)

(DEFPROP GETSPEC
 (LAMBDA(ACTOR VAR MALIST)
  (COND	((EQ (/!/,1 VAR) (QUOTE *UNASSIGNED))
	 (COND (NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE)) ((LIST ACTOR))))
	((LIST NIL))))
EXPR)

(DEFPROP MBIND
 (LAMBDA(VAR VAL ALISTV)
  (COND (NOBIND (MSET VAR VAL (CDR ALISTV))) ((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV))))))
EXPR)

(DEFPROP MBINDV
 (LAMBDA(VAR VAL ALISTV)
  (COND ((NOT VAR)) (NOBIND (MSET VAR VAL (CDR ALISTV))) ((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV))))))
EXPR)

(DECLARE (UNSPECIAL NOBIND))

(DEFPROP MBINDR
 (LAMBDA(VAR RESTRICTIONS VAL ALISTV)
  (OR# (NOT VAR) (AND# (MBIND VAR VAL ALISTV) (SATISFY RESTRICTIONS (CDR ALISTV)))))
EXPR)

(DEFPROP /!/,
 (LAMBDA (L) (/!/,1 (CAR L)))
FEXPR)

(DEFPROP /!/,
 CP-MATCH
CPRINT)

(DEFPROP /!/,1
 (LAMBDA (VAR/ ) ((LAMBDA (PAIR) (COND (PAIR (CADR PAIR)) ((RVALUE VAR/ )))) (ASSOC VAR/  MALIST)))
EXPR)

(DEFPROP SATISFY
 (LAMBDA (RS MALIST) (OR# (NULL RS) (APPLY# (FUNCTION AND#) RS)))
EXPR)

(DECLARE (UNSPECIAL MALIST))

(DEFPROP MSET
 (LAMBDA(VAR VAL MALIST)
  ((LAMBDA(PAIR)
    (COND (PAIR (RPLACA (CDR PAIR) VAL) VAL) ((CERR VARIABLE (QUOTE VAR) UNBOUND IN MATCH ALIST)))
    T)
   (ASSOC VAR MALIST)))
EXPR)

(DEFPROP ASSIGNED?
 (LAMBDA(VAR)
  (PROG	(VAL)
	(RETURN
	 (COND ((SETQ VAL (VLOC VAR)) (NOT (EQ (CADR VAL) (QUOTE *UNASSIGNED))))
	       ((SETQ VAL (BOUNDP VAR)) (NOT (EQ (CDR VAL) (QUOTE *UNASSIGNED))))))))
EXPR)

(DEFPROP CNVINT
 (LAMBDA NIL (SETQ RUNF NIL) (START))
EXPR)

(%DEREAD 72 (FUNCTION COLMAC) 12)

(%DEREAD 100 (FUNCTION ATMAC) 12)

(%DEREAD 41 (FUNCTION EXMAC) 12)

(%DEREAD 54 (FUNCTION COMMAC) 12)

(%DEREAD 73 (FUNCTION EXMAC) 12)